00000000  $SET LIST LISTINCL XREF NOXREFLIST SET NEW INCLNEW                                
00000001  $SET $                                                                            
00000002  $LEVEL 2                                                                          
00000003  $VERSION 30.001                                                                   
00000005  $SET INSTALLATION 1                                                               
00000006  $SET LINEINFO                                                                     
00001000  $SET SEQ 1000+100                                                                 
00001100  $RESET CODETEST                                                                   
00001200  $SET OTHERWISE                                                                    
00001300  $SET NAMECOMP                                                                     
00001400  $SET VMODE                                                                        
00001500 %                                                                                  
00001600 %   BINDER CONTROL CARDS                                                           
00001700 %                                                                                  
00001800  $SET AUTOBIND                                                                     
00001900  $BINDER RESET LIST STACK                                                          
00002000  $USE RBINDCONTROL FOR BINDERCONTROL                                               
00002100  $USE ABFILECONTROL FOR AUTOBINDFILECONTROL                                        
00002200  $USE CODE FOR FILE1                                                               
00002300  $USE LISTTOG FOR COMPLISTOG                                                       
00002400  $USE CODETOG FOR COMPCODETOG                                                      
00002500  $USE ERRLISTTOG FOR COMPERRLISTOG                                                 
00002600  $USE BINDLINE FOR LINE                                                            
00002700  $USE BINDERROR FOR ERRORFILE                                                      
00002800  $BIND COMPBIND FROM SYSTEM/COMPBIND                                               
00002900  $USE NAMESTOG FOR COMPSTACKTOG                                                    
00003000 %                                                                                  
00003100 REAL PROCEDURE PASCALCOMPILER(SEGZERO);                                            
00003200 %              **************                                                      
00003300 REAL ARRAY SEGZERO[*];                                                             
00003400 %***********************************************************************           
00003500 %***********************************************************************           
00003600 %**                                                                   **           
00003700 %**     (C) COPYRIGHT 1976  A.H.J.SALE AND R.A.FREAK                  **           
00003800 %**             HOBART, TASMANIA                                      **           
00003900 %**                                                                   **           
00004000 %**     NOT TO BE REPRODUCED IN WHOLE OR IN PART                      **           
00004100 %**     WITHOUT WRITTEN PERMISSION FROM THE AUTHORS:                  **           
00004200 %**             C/0 DEPARTMENT OF INFORMATION SCIENCE                 **           
00004300 %**             UNIVERSITY OF TASMANIA                                **           
00004400 %**             BOX 252C, G.P.O., HOBART                              **           
00004500 %**             TASMANIA  7001                                        **           
00004600 %**                                                                   **           
00004700 %**     ALL RIGHTS RESERVED                                           **           
00004800 %**                                                                   **           
00004900 %**     COMPILER FOR LANGUAGE "PASCAL" ON BURROUGHS B6700             **           
00005000 %**             WRITTEN IN BURROUGHS EXTENDED ALGOL                   **           
00005100 %**             1976 AUGUST 16                                        **           
00005200 %**                                                                   **           
00005300 %**     USING COPYRIGHT PACKAGES DEVELOPED BY AUTHORS:                **           
00005400 %**             PACKAGE1 : STANDARD INPUT AND OPTIONS                 **           
00005500 %**             PACKAGE2 : CODE FILE GENERATION                       **           
00005600 %**             PACKAGE3 : LINEINFO GENERATION                        **           
00005700 %**                                                                   **           
00005800 %***********************************************************************           
00005900 %***********************************************************************           
00006000 BEGIN                                                                              
00006100   LABEL SHEERANDUTTERDISASTER,GOODBYE;                                             
00006200   INTEGER                                                                          
00006300     NOOFERRORS,          %THESE DECLARATIONS MUST BE FIRST                         
00006400     CARDCOUNT,           %IN THE COMPILER                                          
00006500     INCLSEQ;             %FOR ?CS MESSAGE TO WORK                                  
00006600   DEFINE                                                                           
00006700         LLIST           =LISTTOG#,                                                 
00006800         LCODE           =CODETOG#,                                                 
00006900         ERRLIST         =ERRLISTTOG#,                                              
00007000         LSTACK          =NAMESTOG#,                                                
00007100         HEXCODE         =HEXCODETOG#;                                              
00007200                                                                                    
00007300 %***********************************************************************           
00007400 %*                                                                                 
00007500 %* (C) COPYRIGHT 1976 A.H.J.SALE                                                   
00007600 %*                    DEPARTMENT OF INFORMATION SCIENCE                            
00007700 %*                    UNIVERSITY OF TASMANIA                                       
00007800 %*                    BOX 252C  G.P.O.  HOBART                                     
00007900 %*                    TASMANIA  7001                                               
00008000 %*                                                                                 
00008100 %* PASCAL COMPILER FOR BURROUGHS B6700                                             
00008200 %*                                                                                 
00008300 %***********************************************************************           
00008400                                                                                    
00008500 %=======================================================================           
00008600 % IMPLEMENTATION-DEPENDENT DEFINES                                                 
00008700 %=======================================================================           
00008800                                                                                    
00008900 DEFINE                                                                             
00009000                                                                                    
00009100 BASELVL         =2#,            % LEXLVL OF MAIN PROGRAM                           
00009200                                                                                    
00009300 NIL             =0#,            % THE NIL POINTER VALUE                            
00009400                                                                                    
00009500 LOWFIELD1       =[7:8]#,        % SUBFIELDS OF LOWFIELD                            
00009600 LOWFIELD2       =[15:8]#,                                                          
00009700 LOWFIELD        =[15:16]#,      % STANDARD LOW 16 BITS                             
00009800 MIDFIELD        =[31:16]#,      % STANDARD MIDDLE 16 BITS                          
00009900 TOPFIELD        =[47:16]#,      % STANDARD TOP 16 BITS                             
00010000 TOPFIELD1       =[47:8]#,       % SUBFIELDS OF TOPFIELD                            
00010100 TOPFIELD2       =[39:8]#,                                                          
00010200                                                                                    
00010300 INTEST(EL,SET)  =(SET).[(EL):1]#,   % FOR TESTING SET INCLUSION                    
00010400 SYMBOLIN(SET)   =(SET).[SYMBOL:1]#,  % DITTO                                       
00010500 SETB(EL)        =TRUE[EL:1]#,   % FOR USE IN BUILDING SETS (&S)                    
00010600                                                                                    
00010700 INSTALLATIONNO  =100#,           % FOR INTRINSIC USE                               
00010800 PASCALINTRINSIC(NO) = NO & INSTALLATIONNO [23:11]#,                                
00010900                                                                                    
00011000 MAXINT          =549755813887#,   % MAXIMUM INTEGER                                
00011100 LONGSET(X)      =((FORM(X)=POWER) AND (SETTYPE(X)=LSET))#,                         
00011200 SHORTSET(X)     =((FORM(X)=POWER) AND (SETTYPE(X)=SSET))#;                         
00011300                                                                                    
00011400 DEFINE                                                                             
00011500         NEWIDENTRECORDWITHNAME(P)=                                                 
00011600         BEGIN                                                                      
00011700           NEW(P,OTHERIDENTSIZE+(LENGTH DIV CHARSPERWORD)+1);                       
00011800           REPLACE POINTER(HEAP[P+OTHERIDENTSIZE]) BY NAMEBUF0                      
00011900             FOR (LENGTH+1);                                                        
00012000           NAME(P):=P+OTHERIDENTSIZE;                                               
00012100         END#,                                                                      
00012200                                                                                    
00012300         LINKINTOSTACK(P)=                                                          
00012400         BEGIN                                                                      
00012500           IF (STACKHEADP = NIL) THEN BEGIN                                         
00012600             STACKHEADP:=P;                                                         
00012700           END ELSE BEGIN                                                           
00012800             BUILDPTR(STACKTAILP):=P;                                               
00012900           END;                                                                     
00013000           STACKTAILP:=P;                                                           
00013100         END#;                                                                      
00013200                                                                                    
00013300 %=======================================================================           
00013400 % CONSTANT DEFINES                                                                 
00013500 %=======================================================================           
00013600                                                                                    
00013700 DEFINE                                                                             
00013800                                                                                    
00013900 MAXLEVEL        =31#,           % MAXIMUM LEXICAL LEVEL OF D REGISTERS             
00014000 MAXTOP          =50#,           % MAXIMUM NESTING DEPTH OF DISPLAY VEC             
00014100 INTSIZE         =1#,            % SIZE OF INTEGER IN STORAGE UNITS                 
00014200 REALSIZE        =1#,            % SIZE OF REAL IN STORAGE UNITS                    
00014300 BOOLSIZE        =1#,            % SIZE OF BOOLEAN IN STORAGE UNITS                 
00014400 CHARSIZE        =1#,            % SIZE OF CHAR IN STORAGE UNITS                    
00014500 CHARSPERWORD    =6#,            % NO OF EBCDIC CHARS PER STORAGE UNIT              
00014600 BITSPERWORD     =48#,           % NO BITS PER WORD                                 
00014700 SETSIZE         =1#,            % SIZE OF SET IN STORAGE UNITS                     
00014800 PTRSIZE         =1#,            % SIZE OF POINTER IN STORAGE UNITS                 
00014900 MARKSTACKSIZE   =2#,            % NO OF WORDS IN MARK STACK                        
00015000 INTBITSIZE      =48#,           % SIZE IF INTEGER IN BITS                          
00015100 REALBITSIZE     =48#,           % SIZE OR REAL IN BITS                             
00015200 BOOLBITSIZE     =1#,            % SIZE OF BOOLEAN IN BITS                          
00015300 CHARBITSIZE     =8#,            % SIZE OF CHAR IN BITS                             
00015400 SETBITSIZE      =48#,           % SIZE OF SET IN BITS                              
00015500 PTRBITSIZE      =48#;           % SIZE OF POINTER IN BITS                          
00015600                                                                                    
00015700 %=======================================================================           
00015800 % DEFINES FOR DISTINCT TYPES                                                       
00015900 %=======================================================================           
00016000                                                                                    
00016100 DEFINE                                                                             
00016200                                                                                    
00016300 TYPESYMBOL      =INTEGER#,      % THE TYPE OF SYMBOLS                              
00016400                                                                                    
00016500 IDENT           =0#,                                                               
00016600 INTCONST        =1#,                                                               
00016700 REALCONST       =2#,                                                               
00016800 STRINGCONST     =3#,                                                               
00016900 NOTSY           =4#,                                                               
00017000 MULOP           =5#,                                                               
00017100 ADDOP           =6#,                                                               
00017200 RELOP           =7#,                                                               
00017300 LPARENT         =8#,                                                               
00017400 RPARENT         =9#,                                                               
00017500 LBRACK          =10#,                                                              
00017600 RBRACK          =11#,                                                              
00017700 COMMA           =12#,                                                              
00017800 SEMICOLON       =13#,                                                              
00017900 PERIOD          =14#,                                                              
00018000 ARROW           =15#,                                                              
00018100 COLON           =16#,                                                              
00018200 BECOMES         =17#,                                                              
00018300 LABELSY         =18#,                                                              
00018400 CONSTSY         =19#,                                                              
00018500 TYPESY          =20#,                                                              
00018600 VARSY           =21#,                                                              
00018700 FUNCSY          =22#,                                                              
00018800 FORMATSY        =23#,                                                              
00018900 PROCSY          =24#,                                                              
00019000 SETSY           =25#,                                                              
00019100 PACKEDSY        =26#,                                                              
00019200 ARRAYSY         =27#,                                                              
00019300 RECORDSY        =28#,                                                              
00019400 FILESY          =29#,                                                              
00019500 FORWARDSY       =30#,                                                              
00019600 BEGINSY         =31#,                                                              
00019700 IFSY            =32#,                                                              
00019800 CASESY          =33#,                                                              
00019900 REPEATSY        =34#,                                                              
00020000 WHILESY         =35#,                                                              
00020100 FORSY           =36#,                                                              
00020200 WITHSY          =37#,                                                              
00020300 GOTOSY          =38#,                                                              
00020400 ENDSY           =39#,                                                              
00020500 ELSESY          =40#,                                                              
00020600 UNTILSY         =41#,                                                              
00020700 OFSY            =42#,                                                              
00020800 DOSY            =43#,                                                              
00020900 TOSY            =44#,                                                              
00021000 DOWNTOSY        =45#,                                                              
00021100 THENSY          =46#,                                                              
00021200 OTHERSY         =47#,                                                              
00021300                                                                                    
00021400 TYPEOPERATOR    =INTEGER#,      % THE TYPE OF OPERATOR                             
00021500                                                                                    
00021600 MUL             =0#,                                                               
00021700 REALDIV         =1#,                                                               
00021800 ANDOP           =2#,                                                               
00021900 JDIV            =3#,                                                               
00022000 IMOD            =4#,                                                               
00022100 PLUS            =5#,                                                               
00022200 MINUS           =6#,                                                               
00022300 OROP            =7#,                                                               
00022400 LTOP            =8#,                                                               
00022500 LEOP            =9#,                                                               
00022600 GEOP            =10#,                                                              
00022700 GTOP            =11#,                                                              
00022800 NEOP            =12#,                                                              
00022900 EQOP            =13#,                                                              
00023000 INOPR           =14#,                                                              
00023100 NOOPR           =15#,                                                              
00023200  $SET OMIT = NOT OTHERWISE                                                         
00023300 ELSEOP          =16#,                                                              
00023400 OTHERWISEOP     =17#,                                                              
00023500  $POP OMIT                                                                         
00023600 FWDOP           =18#,                                                              
00023700 EXTERNOP        =19#,                                                              
00023800                                                                                    
00023900 TYPESETOFSYS    =BOOLEAN#,      % A SET OF SYMBOL (48 BITS ENOUGH)                 
00024000                                                                                    
00024100 TYPECSTCLASS    =INTEGER#,      % TYPE OF CONSTANT CLASS                           
00024200                                                                                    
00024300 REEL            =0#,                                                               
00024400 PSET            =1#,                                                               
00024500 STRG            =2#,                                                               
00024600                                                                                    
00024700 TYPECSP         =INTEGER#,      % POINTER TO CONSTANT                              
00024800                                                                                    
00024900 TYPELEVRANGE    =INTEGER#,      % TYPE OF LEX LEVEL                                
00025000                                                                                    
00025100 TYPEADDRRANGE   =INTEGER#,      % TYPE OF DISPLACEMENT                             
00025200                                                                                    
00025300 TYPESTRUCTFORM  =INTEGER#,      % TYPE OF STRUCTURE FORM                           
00025400                                                                                    
00025500 SCALAR          =0#,                                                               
00025600 SUBRANGE        =1#,                                                               
00025700 POINTERS        =2#,                                                               
00025800 POWER           =3#,                                                               
00025900 ARRAYS          =4#,                                                               
00026000 RECORDS         =5#,                                                               
00026100 FILES           =6#,                                                               
00026200 TAGFLD          =7#,                                                               
00026300 VARIANT         =8#,                                                               
00026400                                                                                    
00026500 TYPEDECLKIND    =INTEGER#,      % TYPE OF DECLARATION KIND                         
00026600                                                                                    
00026700 STANDARD        =0#,                                                               
00026800 DECLARED        =1#,                                                               
00026900                                                                                    
00027000 STDPASCAL       =0#,                                                               
00027100 NONSTDPASCAL    =1#,                                                               
00027200                                                                                    
00027300 TYPESTRUCTPTR   =INTEGER#,      % TYPE OF STRUCTURE POINTER                        
00027400                                                                                    
00027500 TYPEIDENTPTR    =INTEGER#,      % TYPE OF IDENTIFIER POINTER                       
00027600                                                                                    
00027700 TYPEIDCLASS     =INTEGER#,      % TYPE OF IDENTIFIER CLASS                         
00027800                                                                                    
00027900 TYPES           =0#,                                                               
00028000 KONST           =1#,                                                               
00028100 VARS            =2#,                                                               
00028200 FIELD           =3#,                                                               
00028300 PROC            =4#,                                                               
00028400 FUNC            =5#,                                                               
00028500 FORMATS         =6#,                                                               
00028600                                                                                    
00028700 TYPESETOFIDS    =BOOLEAN#,      % TYPE OF SET OF IDCLASS                           
00028800                                                                                    
00028900 TYPEIDKIND      =INTEGER#,      % TYPE OF IDENTIFIER KIND                          
00029000                                                                                    
00029100 ACTUAL          =0#,                                                               
00029200 FORMAL          =1#,                                                               
00029300                                                                                    
00029400 TYPEDISPRANGE   =INTEGER#,      % TYPE OF DISPLACEMENT RANGE                       
00029500                                                                                    
00029600 TYPEWHERE       =INTEGER#,      % TYPE OF WHERE WE ARE                             
00029700                                                                                    
00029800 BLCK            =0#,                                                               
00029900 CREC            =1#,                                                               
00030000 VREC            =2#,                                                               
00030100 REC             =3#,                                                               
00030200                                                                                    
00030300 TYPEATTRKIND    =INTEGER#,      % TYPE OF ATTRIBUTE KIND                           
00030400                                                                                    
00030500 CST             =0#,                                                               
00030600 VARBL           =1#,                                                               
00030700 EXPR            =2#,                                                               
00030800                                                                                    
00030900 TYPEVACCESS     =INTEGER#,      % TYPE OF VARIABLE ACCESS                          
00031000                                                                                    
00031100 DRCT            =0#,                                                               
00031200 INDRCT          =1#,                                                               
00031300 INXD            =2#,                                                               
00031400                                                                                    
00031500 TYPETESTP       =INTEGER#,      % POINTER TO TESTP                                 
00031600                                                                                    
00031700 TYPELBP         =INTEGER#,      % POINTER TO LABL                                  
00031800                                                                                    
00031900 TYPESIO         =INTEGER#,      % D1SLOT ALLOCATED FOR I/O                         
00032000 NOD1SLOT        =0#,                                                               
00032100 D1SLOT          =1#,                                                               
00032200                                                                                    
00032300 UNPACKEDSTRUC   =0#,                                                               
00032400 PACKEDSTRUC     =1#,                                                               
00032500                                                                                    
00032600 NOTEXTFIL       =0#,                                                               
00032700 TEXTFIL         =1#,                                                               
00032800                                                                                    
00032900 INLINECODE      =0#,                                                               
00033000 PASSPROC        =1#,                                                               
00033100                                                                                    
00033200 FNCURRENT = 1#,                                                                    
00033300 FNFINISHED = 0#,                                                                   
00033400                                                                                    
00033500 SSET            =0#,                                                               
00033600 LSET            =1#,                                                               
00033700                                                                                    
00033800 TYPEVALU        =REAL#;         % A ONE-WORD VALUE                                 
00033900                                                                                    
00034000 %=====================================================================             
00034100 % STRUCTURE RECORD ACCESS AND COMPONENTS                                           
00034200 %=======================================================================           
00034300                                                                                    
00034400 DEFINE                                                                             
00034500         MARKED(S)=HEAP[S].[47:1]#,                                                 
00034600         PACKED(S)=HEAP[S].[46:1]#,                                                 
00034700         BITS(S)=HEAP[S].[45:6]#,                                                   
00034800         SWORDS(S)=HEAP[S].LOWFIELD#,                                               
00034900         FORM(S)=HEAP[S].MIDFIELD#,                                                 
00035000 % SCALAR                                                                           
00035100         SIO(S)=HEAP[S+1].[47:1]#,                                                  
00035200         SD1DISP(S)=HEAP[S+1].[46:15]#,                                             
00035300         SCALKIND(S)=HEAP[S+1].MIDFIELD#,                                           
00035400         FCONST(S)=HEAP[S+1].LOWFIELD#,                                             
00035500 % SUBRANGE                                                                         
00035600         RANGETYPE(S)=HEAP[S+1]#,                                                   
00035700         SMIN(S)=HEAP[S+2]#,                                                        
00035800         SMAX(S)=HEAP[S+3]#,                                                        
00035900 % POINTER                                                                          
00036000         ELTYPE(S)=HEAP[S+1].LOWFIELD#,                                             
00036100 % POWER                                                                            
00036200         ELSET(S)=HEAP[S+1].LOWFIELD#,                                              
00036300         SETTYPE(S)=HEAP[S+1].MIDFIELD#,                                            
00036400 % ARRAYS                                                                           
00036500         AELTYPE(S)=HEAP[S+1].LOWFIELD#,                                            
00036600         INXTYPE(S)=HEAP[S+1].MIDFIELD#,                                            
00036700         ELSPERWORD(S)=HEAP[S+1].TOPFIELD#,                                         
00036800 % RECORDS                                                                          
00036900         FSTFLD(S)=HEAP[S+1].LOWFIELD#,                                             
00037000         RECVAR(S)=HEAP[S+1].MIDFIELD#,                                             
00037100 % FILES                                                                            
00037200         FILTYPE(S)=HEAP[S+1].LOWFIELD#,                                            
00037300         ORIGFILTYPE(S) = HEAP[S+1].MIDFIELD#,                                      
00037400         TEXTFILE(S)=HEAP[S+1].[47:1]#,                                             
00037500 % TAGFIELD                                                                         
00037600         TAGFIELDP(S)=HEAP[S+1].LOWFIELD#,                                          
00037700         FSTVAR(S)=HEAP[S+1].MIDFIELD#,                                             
00037800 % VARIANT                                                                          
00037900         NXTVAR(S)=HEAP[S+1].LOWFIELD#,                                             
00038000         SUBVAR(S)=HEAP[S+1].MIDFIELD#,                                             
00038100         VARVAL(S)=HEAP[S+1].TOPFIELD#,                                             
00038200                                                                                    
00038300 % SIZES OF STRUCTURE RECORDS                                                       
00038400         SUBRANGESTRUCTSIZE=4#,                                                     
00038500         OTHERSTRUCTSIZE=2#;                                                        
00038600                                                                                    
00038700 %=======================================================================           
00038800 % IDENTIFIER RECORD ACCESS AND COMPONENTS                                          
00038900 %=======================================================================           
00039000                                                                                    
00039100 DEFINE                                                                             
00039200         NAME(S)=HEAP[S].TOPFIELD#,                                                 
00039300         LLINK(S)=HEAP[S].MIDFIELD#,                                                
00039400         RLINK(S)=HEAP[S].LOWFIELD#,                                                
00039500         KLASS(S)=HEAP[S+1].TOPFIELD#,                                              
00039600         IDTYPE(S)=HEAP[S+1].MIDFIELD#,                                             
00039700         NEXT(S)=HEAP[S+1].LOWFIELD#,                                               
00039800 % KONST                                                                            
00039900         VALUES(S)=HEAP[S+2]#,                                                      
00040000 % VARS  (AND STRING CONSTANTS)                                                     
00040100         VKIND(S)=HEAP[S+2].[47:1]#,                                                
00040200         VD1OFFSET(S)=HEAP[S+2].[45:10]#,                                           
00040300         VFORCONTRL(S)=HEAP[S+2].[46:1]#,                                           
00040400         VLEV(S)=HEAP[S+2].MIDFIELD#,                                               
00040500         VADDR(S)=HEAP[S+2].LOWFIELD#,                                              
00040600 % FIELD                                                                            
00040700         FLDADDR(S)=HEAP[S+2]#,                                                     
00040800         PACKEDFIELD(S)=HEAP[S+3].[47:1]#,                                          
00040900         BITADDR(S)=HEAP[S+3].LOWFIELD#,                                            
00041000         BITRANGE(S)=HEAP[S+3].MIDFIELD#,                                           
00041100 % PROC, FUNC                                                                       
00041200         PFDECLKIND(S)=HEAP[S+2].TOPFIELD1#,                                        
00041300         PFSTD(S)=HEAP[S+2].TOPFIELD2#,                                             
00041400   % STANDARD, INTRINSIC                                                            
00041500         KEY(S)=HEAP[S+2].MIDFIELD#,                                                
00041600   % DECLARED                                                                       
00041700         PFLEV(S)=HEAP[S+2].MIDFIELD#,                                              
00041800         PFDPLMT(S)=HEAP[S+2].LOWFIELD#,                                            
00041900         FNCDPLMT(S)=HEAP[S+3].TOPFIELD#,                                           
00042000         SBLDGPTR(S)=HEAP[S+3].MIDFIELD#,                                           
00042100         PFKIND(S)=HEAP[S+3].LOWFIELD#,                                             
00042200         FORWARDDECL(S)=HEAP[S+4].[47:1]#,                                          
00042300         FPROCPARAM(S)=HEAP[S+4].[46:1]#,                                           
00042400         FNCOMPLETE(S) = HEAP[S+4].[45:1]#,                                         
00042500         BINDIN(S) = HEAP[S+4].[44:1]#,                                             
00042600         FPARAMLIST(S)=HEAP[S+4].MIDFIELD#,                                         
00042700         MPCWP(S) = HEAP[S+5]#,                                                     
00042800                                                                                    
00042900 % SIZES OF IDENTIFIER RECORDS                                                      
00043000         PROCFUNCSIZE=6#,                                                           
00043100         FIELDSIZE=4#,                                                              
00043200         OTHERIDENTSIZE=3#;                                                         
00043300                                                                                    
00043400 %=======================================================================           
00043500 % STACK BUILDING CODE RECORDS                                                      
00043600 %=======================================================================           
00043700                                                                                    
00043800 DEFINE                                                                             
00043900         TYPESTACKPTR=INTEGER#,                                                     
00044000                                                                                    
00044100         BUILDKIND(P)=HEAP[P].LOWFIELD#,                                            
00044200         BUILDPTR(P) =HEAP[P].MIDFIELD#,                                            
00044300         BUILDID(P)=HEAP[P].TOPFIELD#,                                              
00044400         BUILDVAL(P)=HEAP[P+1]#,                                                    
00044500                                                                                    
00044600         ONEWORD                 =0#,                                               
00044700         DOUBLEWORD              =1#,                                               
00044800         ARRAYDESCRIPTOR         =2#,                                               
00044900         FPBDESCRIPTOR           =3#,                                               
00045000         PCWWORD                 =4#,                                               
00045100         FUNNYSIRW               =5#,                                               
00045200         ONEWORDCONSTANT         =6#,                                               
00045300         STATSARRAY              =7#,                                               
00045400                                                                                    
00045500         DESCPCWSIZE             =2#,                                               
00045600         OTHERTHINGSIZE          =1#;                                               
00045700                                                                                    
00045800 %=======================================================================           
00045900 % DISPLAY FIELDS                                                                   
00046000 %=======================================================================           
00046100                                                                                    
00046200 DEFINE                                                                             
00046300         FNAME(J)=                                                                  
00046400                 DISPLAY[J].LOWFIELD#,                                              
00046500         FLABEL(J)=                                                                 
00046600                 DISPLAY[J].MIDFIELD#,                                              
00046700         OCCUR(J)=                                                                  
00046800                 DISPLAY[J].TOPFIELD#,                                              
00046900 %CREC                                                                              
00047000         CLEV(J)=                                                                   
00047100                 DISPLAY1[J].LOWFIELD#,                                             
00047200         CDSPL(J)=                                                                  
00047300                 CDISPL(J)#,                                                        
00047400         CDISPL(J)=                                                                 
00047500                 DISPLAY1[J].MIDFIELD#,                                             
00047600         CINDX(J)=                                                                  
00047700                 DISPLAY1[J].TOPFIELD#,                                             
00047800 %VREC                                                                              
00047900         VDLEV(J)=                                                                  
00048000                 DISPLAY1[J].LOWFIELD1#,                                            
00048100         VLL(J)=                                                                    
00048200               DISPLAY1[J].LOWFIELD2#,                                              
00048300         VDDSPL(J)=                                                                 
00048400                 DISPLAY1[J].MIDFIELD#,                                             
00048500         VDLC(J)=                                                                   
00048600                 DISPLAY1[J].TOPFIELD#,                                             
00048700                                                                                    
00048800         DISPLAYSIZE = 1#;                                                          
00048900                                                                                    
00049000 %=======================================================================           
00049100 % LABEL RECORDS                                                                    
00049200 %=======================================================================           
00049300                                                                                    
00049400 DEFINE                                                                             
00049500         NEXTLAB(P)=HEAP[P].LOWFIELD#,                                              
00049600         LABNAME(P)=HEAP[P].MIDFIELD#,                                              
00049700         LABVAL(P) =HEAP[P].[46:15]#,                                               
00049800         DEFINED(P)=HEAP[P].[47:1]#,                                                
00049900         LABLEV(P) = HEAP[P+1].MIDFIELD#,                                           
00050000         LABADDR(P) = HEAP[P+1].LOWFIELD#,                                          
00050100         STACKPCW(P) = HEAP[P+1].TOPFIELD#,                                         
00050200                                                                                    
00050300         LABELSIZE       =2#;    % ONE WORD LABEL RECORDS                           
00050400                                                                                    
00050500 %=======================================================================           
00050600 % TEST POINTER RECORDS                                                             
00050700 %=======================================================================           
00050800                                                                                    
00050900 DEFINE                                                                             
00051000         ELT1(P)      =HEAP[P].LOWFIELD#,                                           
00051100         ELT2(P)      =HEAP[P].MIDFIELD#,                                           
00051200         LASTTESTP(P) =HEAP[P].TOPFIELD#,                                           
00051300                                                                                    
00051400         TESTPSIZE       =1#;    % ONE WORD TESTPOINTER RECORDS                     
00051500                                                                                    
00051600 %=======================================================================           
00051700 % ADDRESSES OF GLOBAL OBJECTS AT RUN-TIME                                          
00051800 %=======================================================================           
00051900                                                                                    
00052000 DEFINE                                                                             
00052100         NOOFSPECWORDS   =8#,                                                       
00052200         FILEDATASIZE    =7#,                                                       
00052300         ADDRHEAP        =A#,                                                       
00052400         ADDRHEAPPTR     =A+1#,                                                     
00052500         ADDRIFILE       =A+2#,                                                     
00052600         ADDRIBUF        =A+3#,                                                     
00052700         ADDRIFILEDATA   =A+4#,                                                     
00052800         ADDROFILE       =A+5#,                                                     
00052900         ADDROBUF        =A+6#,                                                     
00053000         ADDROFILEDATA  =A+7#;                                                      
00053100                                                                                    
00053200 INTEGER                                                                            
00053300         A;              % HOLDS DISPL OF FIRST OF THINGS                           
00053400                                                                                    
00053500 %===================================================================               
00053600 %   PASCAL INTRINSICS                                                              
00053700 %===================================================================               
00053800                                                                                    
00053900   DEFINE                                                                           
00054000     PASCALERRORINTR = 1#,                                                          
00054100     PASCALREADINTR = 2#,                                                           
00054200     PASCALWRITEINTR = 3#,                                                          
00054300     PASCALARRAYEQUALINTR = 5#,                                                     
00054400     PASCALARRAYCOMPAREINTR = 6#,                                                   
00054500     PASCALLONGSETOPERATORINTR = 7#,                                                
00054600     PASCALLONGSETCOMPAREINTR = 8#,                                                 
00054700     PASCALLONGSETCARDINALITYINTR = 9#,                                             
00054800     PASCALTIMESTAMPINTR = 10#,                                                     
00054900     PASCALFLUSHBUFFERINTR = 11#,                                                   
00055000     PASCALTIMING = 12#,                                                            
00055100     PASCALLONGSETBITSINTR = 14#,                                                   
00055200     PASCALLONGSETININTR = 15#,                                                     
00055300     PASCALPACKINTR = 16#,                                                          
00055400     PASCALUNPACK1INTR = 17#,                                                       
00055500     PASCALUNPACK4INTR = 18#,                                                       
00055600     PASCALUNPACK6INTR = 19#,                                                       
00055700     PASCALUNPACK8INTR = 20#,                                                       
00055800     PASCALUNPACK48INTR = 21#,                                                      
00055900     PASCALTEXTREADINTR = 22#,                                                      
00056000     PASCALTEXTWRITEINTR = 23#,                                                     
00056100     PASCALTEXTOPENINTR = 24#;                                                      
00056200                                                                                    
00056300 %======================================================================           
00056400 %   RUN TIME ERRORS                                                                
00056500 %=======================================================================           
00056600                                                                                    
00056700   DEFINE                                                                           
00056800     SUCCPREDERROR = 1#,                                                            
00056900     HEAPFULLERROR = 2#,                                                            
00057000     NOCASELABERROR = 3#,                                                           
00057100     FORVARERROR = 4#,                                                              
00057200     BOUNDSERROR = 5#;                                                              
00057300                                                                                    
00057400                                                                                    
00057500 %********************************************************************             
00057600 %   BINDER CONTROL                                                                 
00057700 %**********************************************************************           
00057800                                                                                    
00057900 DEFINE                                                                             
00058000   BINDBITS = [47:48]#,                                                             
00058100 %                                                                                  
00058200   NWORDS = [19:20]#,                                                               
00058300   SCV = [39:20]#,                                                                  
00058400   UCV = [47:8]#,                                                                   
00058500 %                                                                                  
00058600   BSEGMENT = [13:14]#,                                                             
00058700   BLL = [18:5]#,                                                                   
00058800   WORDOFFSET = [31:12]#,                                                           
00058900   BYTEOFFSET = [35:3]#,                                                            
00059000 %                                                                                  
00059100   CODEPAGE = [12:13]#,                                                             
00059200   REBIT = [15:1]#,                                                                 
00059300   LDIRLL = [20:5]#,                                                                
00059400   OFFSET = [25:5]#,                                                                
00059500   ENTRY = [27:1]#,                                                                 
00059600   LDIRSEGMENT = [45:18]#,                                                          
00059700   CBIT = [46:1]#,                                                                  
00059800   EXBIT = [47:1]#,                                                                 
00059900 %                                                                                  
00060000   MAXBINDCHARS = 599#,                                                             
00060100   MAXFIBSIZE = 199#,                                                               
00060200   CODEWRANGE = 4095#,                                                              
00060300 %                                                                                  
00060400   IDBUILD = 0#,                                                                    
00060500   ADRBUILD = 1#,                                                                   
00060600   MPCWBUILD = 2#,                                                                  
00060700   PARAMS = 3#,                                                                     
00060800   FUNCVAR = 4#,                                                                    
00060900 %                                                                                  
00061000   DONTBIND = 0#,                                                                   
00061100   BINDITIN = 1#;                                                                   
00061200 %                                                                                  
00061300                                                                                    
00061400 %=======================================================================           
00061500 % HEAP CONTROL                                                                     
00061600 %=======================================================================           
00061700                                                                                    
00061800 DEFINE                                                                             
00061900         HEAPLIMIT       =20000#,        % TOP WORD OF HEAP VECTOR                  
00062000         CHECKPATTERN    =4"FEDC"#,      % CHECKS VALIDITY OF RELEASE PTR           
00062100         CHECKF          =[47:32]#;      % FIELD FOR CHECK PATTERN                  
00062200 INTEGER                                                                            
00062300         TOPOFHEAP;                      % CURRENT LIMIT OF USED  HEAP              
00062400 REAL ARRAY                                                                         
00062500         HEAP[0:HEAPLIMIT];              % THE HEAP VECTOR                          
00062600                                                                                    
00062700 %=======================================================================           
00062800 % VARIABLES AND OBJECTS IN GLOBAL AREA                                             
00062900 %=======================================================================           
00063000                                                                                    
00063100 TYPESYMBOL                                                                         
00063200         SYMBOL;                 % LAST SYMBOL SCANNED                              
00063300 TYPEOPERATOR                                                                       
00063400         OP;                     % CLASSIFICATION OF -SYMBOL-                       
00063500 TYPEVALU                                                                           
00063600         VAL;                    % VALUE OF LAST CONSTANT                           
00063700 INTEGER                                                                            
00063800         BASELC,                 % TOP OF BASE STACK USED IN STATS                  
00063900         STATSMAX,               % TOP OF STATS CHAIN                               
00064000         STATSMIN,               % HOW FAR ALREADY IN STACK BLDG CODE               
00064100         LENGTH;                 % LENGTH OF LAST STRING/IDENT/NUMBER               
00064200 REAL ARRAY                                                                         
00064300         TRUNCNAME[0:1],         % TRUNCATED PROC NAMES FOR STATS                   
00064400         STATSTABLE[0:1999],     % HOLDS STATS INFO (1000 ENTRIES)                  
00064500         NAMEBUF[0:14];          % HOLDS LAST STRING/IDENT                          
00064600 POINTER                                                                            
00064700         NAMEBUF1,                                                                  
00064800         NAMEBUF0;                                                                  
00064900 REAL ARRAY                                                                         
00065000         CARDWBUF[0:14];         % WORD ORGANIZED BUFFER                            
00065100 EBCDIC ARRAY                                                                       
00065200         CARDBUF[0]=CARDWBUF[*]; % INPUT BUFFER IMAGE                               
00065300 BOOLEAN                                                                            
00065400         ANYSTATISTICSFLAG,      % SET IF ANYTHING HAS STATS                        
00065500         DP,                     % TRUE IN DECLARATION PART                         
00065600         PRTERR;                 % USED TO SUPPRESS ERRORS IN FORWARD PTR           
00065700 INTEGER                                                                            
00065800         ENTRYPOINT;             % LABEL TO ENTER MAINLINE PROGRAM                  
00065900 TYPESTRUCTPTR                                                                      
00066000         INTPTR,                 % THESE ARE POINTERS TO STANDARD TYPES             
00066100         REALPTR,                                                                   
00066200         BOOLPTR,                                                                   
00066300         CHARPTR,                                                                   
00066400         NILPTR,                                                                    
00066500         CHARBUFPTR,                                                                
00066600         WORDBUFPTR,                                                                
00066700         TEXTPTR;                                                                   
00066800 TYPEIDENTPTR                                                                       
00066900         INPUTPTR,                                                                  
00067000         OUTPUTPTR,                                                                 
00067100         UTYPPTR,                % THESE ARE POINTERS TO TEMPLATES                  
00067200         UCSTPTR,                %   WHICH WILL SERVE FOR UNDECLARED                
00067300         UVARPTR,                %   IDS OF THESE KINDS                             
00067400         UFLDPTR,                                                                   
00067500         UPRCPTR,                                                                   
00067600         UFCTPTR,                                                                   
00067700         FWPTR,                  % HEAD OF CHAIN OF FORWARD DECLS                   
00067800         OBPROCP;                                                                   
00067900 TYPETESTP                                                                          
00068000         GLOBTESTP;              % POINTER TO LAST TESTPOINTER                      
00068100 TYPEDISPRANGE                                                                      
00068200         DISX,                   % LEVEL LAST SEARCHED BY SEARCHID                  
00068300         TOP;                    % TOP OF DISPLAY                                   
00068400 TYPESETOFSYS                                                                       
00068500         FSYS,                   % USED IN CALLING BLOCK FROM MAIN PROG             
00068600         CONSTBEGSYS,            % SET OF SYMBOLS FOR TESTING                       
00068700         SIMPTYPEBEGSYS,         %   THESE ARE VIRTUAL CONSTANTS                    
00068800         TYPEBEGSYS,                                                                
00068900         BLOCKBEGSYS,                                                               
00069000         SELECTSYS,                                                                 
00069100         FACBEGSYS,                                                                 
00069200         STATBEGSYS,                                                                
00069300         TYPEDELS;                                                                  
00069400                                                                                    
00069500 REAL ARRAY                                                                         
00069600         DISPLAY,DISPLAY1[0:MAXTOP];                                                
00069700                                 % DISPLAY STACK                                    
00069800                                                                                    
00069900 EBCDIC ARRAY                                                                       
00070000         LBUF[0:131];            % COMMON ERROR MESSAGE BUFFER                      
00070100 POINTER                                                                            
00070200         LBUF0;                  % POINTS TO LBUF[0]                                
00070300                                                                                    
00070400                                                                                    
00070500 %=======================================================================           
00070600 % DECLARATIONS FOR INSYMBOL                                                        
00070700 %=======================================================================           
00070800                                                                                    
00070900 INTEGER                                                                            
00071000         INSYK,INSYE,INSYSCAN,INSYSTART;                                            
00071100 POINTER                                                                            
00071200         INSYP,INSYP1,INSYP73,INSYN,INSYN1,LINENUMBERPTR;                           
00071300 TRUTHSET                                                                           
00071400         SEMIASTERISK(";*"),                                                        
00071500         SEMICURLY(";}"),                                                           
00071600         NONDIGITS(NOT "0123456789"),                                               
00071700         NOTALPHANUM (NOT (                                                         
00071800              "ABCDEFGHIJKLMNOPQRSTUVWXYZ"                                          
00071900           OR "abcdefghijklmnopqrstuvwxyz" % LOWER CASE ALPHABET                    
00072000           OR "0123456789_" ) );                                                    
00072100 EBCDIC ARRAY                                                                       
00072200         LINENUMBERBUF[0:11];                                                       
00072300 DOUBLE                                                                             
00072400         DNUMBER;                                                                   
00072500 INTEGER                                                                            
00072600         EXPONENT;                                                                  
00072700 BOOLEAN                                                                            
00072800         POSITIVE;                                                                  
00072900                                                                                    
00073000 %=======================================================================           
00073100 % GLOBAL AND LOCAL ATTRIBUTE HANDLING FOR EXPRESSIONS                              
00073200 %=======================================================================           
00073300                                                                                    
00073400 DEFINE                                                                             
00073500         DECLARELATTR=                                                              
00073600         TYPESTRUCTPTR LTYPTR;                                                      
00073700         TYPEVACCESS LACCESS;                                                       
00073800         INTEGER LVLEVEL,LDPLMT,LIDPLMT,LCHARSIZE,LBITADDR,LBITRANGE;               
00073900         REAL LCVAL,LBMIN,LBMAX;                                                    
00074000         BOOLEAN LPACKEDSUBRFIELD,LPACKEDARRAY,LCHARDESCR;                          
00074100         TYPEATTRKIND LKIND#,                                                       
00074200                                                                                    
00074300         LATTRPARAMETERS=                                                           
00074400         LTYPTR,LACCESS,LVLEVEL,LDPLMT,LIDPLMT,LCHARSIZE,LPACKEDSUBRFIELD           
00074500            ,LPACKEDARRAY,LBITADDR,LBITRANGE,LCHARDESCR#,                           
00074600                                                                                    
00074700         GATTRPARAMETERS=                                                           
00074800         GTYPTR,GACCESS,GVLEVEL,GDPLMT,GIDPLMT,GCHARSIZE,GPACKEDSUBRFIELD           
00074900            ,GPACKEDARRAY,GBITADDR,GBITRANGE,GCHARDESCR#,                           
00075000                                                                                    
00075100         COPYLATTRGATTR=                                                            
00075200         LTYPTR:=GTYPTR;                                                            
00075300         LACCESS:=GACCESS;                                                          
00075400         LVLEVEL:=GVLEVEL;                                                          
00075500         LDPLMT:=GDPLMT;                                                            
00075600         LIDPLMT:=GIDPLMT;                                                          
00075700         LCVAL:=GCVAL;                                                              
00075800         LBMIN:=GBMIN;                                                              
00075900         LBMAX:=GBMAX;                                                              
00076000         LCHARSIZE:=GCHARSIZE;                                                      
00076100         LBITADDR:=GBITADDR;                                                        
00076200         LBITRANGE:=GBITRANGE;                                                      
00076300         LPACKEDSUBRFIELD:=GPACKEDSUBRFIELD;                                        
00076400         LPACKEDARRAY:=GPACKEDARRAY;                                                
00076500         LCHARDESCR:=GCHARDESCR;                                                    
00076600         LKIND:=GKIND#,                                                             
00076700                                                                                    
00076800         COPYGATTRLATTR=                                                            
00076900         GTYPTR:=LTYPTR;                                                            
00077000         GACCESS:=LACCESS;                                                          
00077100         GVLEVEL:=LVLEVEL;                                                          
00077200         GDPLMT:=LDPLMT;                                                            
00077300         GIDPLMT:=LIDPLMT;                                                          
00077400         GCVAL:=LCVAL;                                                              
00077500         GBMIN:=LBMIN;                                                              
00077600         GBMAX:=LBMAX;                                                              
00077700         GCHARSIZE:=LCHARSIZE;                                                      
00077800         GBITRANGE:=LBITRANGE;                                                      
00077900         GBITADDR:=LBITADDR;                                                        
00078000         GPACKEDSUBRFIELD:=LPACKEDSUBRFIELD;                                        
00078100         GPACKEDARRAY:=LPACKEDARRAY;                                                
00078200         GCHARDESCR:=LCHARDESCR;                                                    
00078300         GKIND:=LKIND#;                                                             
00078400                                                                                    
00078500 TYPESTRUCTPTR GTYPTR;                                                              
00078600 TYPEVACCESS GACCESS;                                                               
00078700 REAL GCVAL,GBMIN,GBMAX;                                                            
00078800 BOOLEAN GPACKEDSUBRFIELD,GPACKEDARRAY,GCHARDESCR;                                  
00078900 TYPEATTRKIND GKIND;                                                                
00079000 INTEGER GVLEVEL,GDPLMT,GIDPLMT,GCHARSIZE,GBITADDR,GBITRANGE;                       
00079100                                                                                    
00079200 %=======================================================================           
00079300 % VIRTUAL SET CONSTANTS                                                            
00079400 %=======================================================================           
00079500                                                                                    
00079600 BOOLEAN                                                                            
00079700         COLONSET,SEMICOLONSET,ENDSET,COMMASET,LPARENTSET,RPARENTSET,               
00079800         BEGINSET,IDENTSET,THENSET,CASESET,                                         
00079900         LBRACKSET,RBRACKSET,UNTILSET,OFSET,                                        
00080000         BECOMESSET,TOSET,ELSESET,DOSET,                                            
00080100         ADDOPSET,MULOPSET,RELOPSET,                                                
00080200         PROCSET,FUNCSET,VARSET;                                                    
00080300 BOOLEAN                                                                            
00080400         COMMARPARENTSET,IDENTCASESET,COMMACOLONSET,COMMARBRACKSET,                 
00080500         COMMACOLONOFSEMICOLONCASESET,CASESEMICOLONSET,                             
00080600         OFLPARENTSET,COMMACOLONLPARENTSET,COMMARBRACKOFSET,                        
00080700         COMMACOLONRPARENTSET,                                                      
00080800         COMMASEMICOLONSET,RPARENTSEMICOLONSET,                                     
00080900         COMMACOLONSEMICOLONSET,SEMICOLONENDSET,SEMICOLONUNTILSET,                  
00081000         BECOMESTODOWNTODOSET,TODOWNTODOSET,COMMACOLONOFSET,                        
00081100         SEMICOLONENDELSEUNTILSET,COLONOFSET,COMMACOLONSEMICOLONOFSET,              
00081200         SEMICOLONRPARENTSET,BEGINPROCFUNCSET,COLONSEMICOLONSET,                    
00081300         COMMASEMICOLONRPARENTSET,IDENTVARPROCFUNCSET,                              
00081400         IDENTRPARENTSET,IDENTLPARENTSET,PROCFUNCSET;                               
00081500 BOOLEAN                                                                            
00081600         KONSTSET,TYPESKONST,TYPESET,KONSTVARFLDFNCSET,VARFIELDFNCPRCSET,           
00081700         VARFLDSET,PRCSET,FNCSET,PRCFNCSET,FORMATSET,                               
00081800         KONSTVARFLDFNCPRCFMTSET;                                                   
00081900 BOOLEAN                                                                            
00082000         PLUSMINUSSET;                                                              
00082100 BOOLEAN                                                                            
00082200         SCALSUBPTRSET;                                                             
00082300                                                                                    
00082400 %=======================================================================           
00082500 %  GLOBAL DATA USED BY READ/WRITE  AND INTRINSIC CALLS                             
00082600 %=======================================================================           
00082700 REAL DATAPOOL,POOLINDEX,POOLMAX;  EBCDIC ARRAY POOLBUFFER[0:6143];                 
00082800 ARRAY POOLWBUFFER[0]=POOLBUFFER[*];                                                
00082900 DEFINE POOLSEGF=[19:20]#, POOLINDEXF=[39:20]#;                                     
00083000                                                                                    
00083100 INTEGER                                                                            
00083200   MAXFIELDSIZE,               %MAX FIELD WIDTH IN FREEFIELD I/O LIST               
00083300   FORMATTEDINADDR,                                                                 
00083400   FORMATTEDOUTADDR,                                                                
00083500   FREEFIELDINADDR,                                                                 
00083600   FREEFIELDOUTADDR,                                                                
00083700   SINADDR,                                                                         
00083800   COSADDR,                                                                         
00083900   ARCTANADDR,                                                                      
00084000   EXPADDR,                                                                         
00084100   LNADDR,                                                                          
00084200   SQRTADDR,                                                                        
00084300   TANADDR,                                                                         
00084400   COTANADDR,                                                                       
00084500   ARCSINADDR,                                                                      
00084600   ARCCOSADDR,                                                                      
00084700   ARCTAN2ADDR,                                                                     
00084800   SINHADDR,                                                                        
00084900   COSHADDR,                                                                        
00085000   TANHADDR,                                                                        
00085100   ATANHADDR,                                                                       
00085200   LOGADDR,                                                                         
00085300   RANDOMADDR,                                                                      
00085400   ERFADDR,                                                                         
00085500   ERFCADDR,                                                                        
00085600   GAMMAADDR,                                                                       
00085700   LNGAMMAADDR,                                                                     
00085800   PASCALERRORADDR,                                                                 
00085900   PASCALREADADDR,                                                                  
00086000   PASCALWRITEADDR,                                                                 
00086100   PASCALARRAYEQUALADDR,                                                            
00086200   PASCALARRAYCOMPAREADDR,                                                          
00086300   PASCALLONGSETOPERATORADDR,                                                       
00086400   PASCALLONGSETCOMPAREADDR,                                                        
00086500   PASCALLONGSETCARDINALITYADDR,                                                    
00086600   PASCALTIMESTAMPADDR,                                                             
00086700   TIMINGADDR,                                                                      
00086800   PASCALFLUSHFILEADDR,                                                             
00086900   PASCALLONGSETBITSADDR,                                                           
00087000   PASCALLONGSETINADDR,                                                             
00087100   PASCALPACKADDR,                                                                  
00087200   PASCALUNPACK1ADDR,                                                               
00087300   PASCALUNPACK4ADDR,                                                               
00087400   PASCALUNPACK6ADDR,                                                               
00087500   PASCALUNPACK8ADDR,                                                               
00087600   PASCALUNPACK48ADDR,                                                              
00087700   PASCALTEXTWRITEADDR,                                                             
00087800   PASCALTEXTREADADDR,                                                              
00087900   PASCALTEXTOPENADDR;                                                              
00088000 BOOLEAN                                                                            
00088100   LISTPROC,                   %TRUE WHEN PROCESSING I/O LIST                       
00088200   LISTELEMENT,                %TRUE IF I/O LIST CONTAINS ELEMENT                   
00088300   READWRITESTMT;              %TRUE FOR READ STMT AND I/O LIST                     
00088400                                                                                    
00088500 %*********************************************************************            
00088600 %   BINDER CONTROL                                                                 
00088700 %**********************************************************************           
00088800                                                                                    
00088900 REAL                                                                               
00089000    BITPICKER,                                                                      
00089100    BEXITPTR,                                                                       
00089200    FIRSTEXECCODE,                                                                  
00089300    ENDOFD2CODE,                                                                    
00089400    SCWIMAGE;                                                                       
00089500 REAL ARRAY                                                                         
00089600    PDIRECTORY [0:29],                                                              
00089700    DIRECTORY [0:CODEWRANGE],                                                       
00089800    FIBPTRS [0:MAXFIBSIZE];                                                         
00089900 INTEGER                                                                            
00090000    FIBPTR,                                                                         
00090100    BINDEX,                                                                         
00090200    LASTPROCDIREC,                                                                  
00090300    PNWORDS,                                                                        
00090400    CBINDCHARS,                                                                     
00090500    ABFILECONTROL;                                                                  
00090600 EBCDIC ARRAY                                                                       
00090700    BINDCONTROL [0:MAXBINDCHARS];                                                   
00090800 REAL ARRAY                                                                         
00090900    RBINDCONTROL[0] = BINDCONTROL[*];                                               
00091000 BOOLEAN                                                                            
00091100    CHANGENEEDED;                                                                   
00091200 % END OF VARDECLS ******************************************************           
00091300 %***********************************************************************           
00091400 %***********************************************************************           
00091500 %**                                                                   **           
00091600 %**     (C) COPYRIGHT 1976  A.H.J.SALE AND R.A.FREAK                  **           
00091700 %**             HOBART, TASMANIA                                      **           
00091800 %**                                                                   **           
00091900 %**     NOT TO BE REPRODUCED IN WHOLE OR IN PART                      **           
00092000 %**     WITHOUT WRITTEN PERMISSION FROM THE AUTHORS:                  **           
00092100 %**             C/0 DEPARTMENT OF INFORMATION SCIENCE                 **           
00092200 %**             UNIVERSITY OF TASMANIA                                **           
00092300 %**             BOX 252C, G.P.O., HOBART                              **           
00092400 %**             TASMANIA  7001                                        **           
00092500 %**                                                                   **           
00092600 %**     ALL RIGHTS RESERVED                                           **           
00092700 %**                                                                   **           
00092800 %**     PACKAGE2                                                      **           
00092900 %**     --------                                                      **           
00093000 %**     IMPLEMENTS A STANDARD CODE GENERATION INTERFACE FOR           **           
00093100 %**     COMPILERS.                                                    **           
00093200 %**     HANDLES DETAILS OF CONSTRUCTION OF OBJECT CODE WORDS,         **           
00093300 %**     OF MOST OF THE SEGMENT DICTIONARY, OF THE CODE-FILE,          **           
00093400 %**     AND INCORPORATES ERROR-CHECKING FACILITIES AND LISTING        **           
00093500 %**     OF OBJECT CODE PRODUCED IN READABLE FORM.                     **           
00093600 %**                                                                   **           
00093700 %**     SMALL SECTIONS MAY BE USER MODIFIED (MAINLY IN OPENING        **           
00093800 %**     AND CLOSING THE CODEFILE); THE MAJOR FUNCTION IS TO           **           
00093900 %**     PROVIDE A SET OF USER-CALLABLE ROUTINES.                      **           
00094000 %**                                                                   **           
00094100 %***********************************************************************           
00094200 %***********************************************************************           
00094300 %***********************************************************************           
00094400 %                                                                                  
00094500 % COMPILER PACKAGE 2 VERSION 1.0  -CODE GENERATION-                                
00094600 %                                                                                  
00094700 % GLOBAL DATA SEGMENT                                                              
00094800 %                                                                                  
00094900 % (C) COPYRIGHT  PROF A.H.J.SALE                                                   
00095000 %                DEPARTMENT OF INFORMATION SCIENCE                                 
00095100 %                UNIVERSITY OF TASMANIA                                            
00095200 %                BOX 252C  G.P.O.  HOBART  TASMANIA 7001                           
00095300 %                                                                                  
00095400 %  NOT USER-INTERFACE IN GENERAL                                                   
00095500 %   BUT SCOPE AND LIFETIME REQUIRE OUTER BLOCK DECLARATION                         
00095600 %                                                                                  
00095700 %***********************************************************************           
00095800                                                                                    
00095900 %=======================================================================           
00096000 %                                                                                  
00096100 % VECTOR SIZE LIMITS                                                               
00096200 %                                                                                  
00096300 %=======================================================================           
00096400                                                                                    
00096500 DEFINE                                                                             
00096600         SEGBUFLIMIT     =4095#, % SEGMENT GENERATION BUFFER                        
00096700                                                                                    
00096800         LABELTABLELIMIT =9999#, % TABLE OF LABELS                                  
00096900                                                                                    
00097000         D1STACKLIMIT    =2047#; % SEGMENT DICTIONARY ("D1 STACK")                  
00097100                                                                                    
00097200 %=======================================================================           
00097300 %                                                                                  
00097400 % WORK VECTORS                                                                     
00097500 %                                                                                  
00097600 %=======================================================================           
00097700                                                                                    
00097800 REAL ARRAY                                                                         
00097900                                                                                    
00098000         SEGBUF[0:SEGBUFLIMIT],  % DATA AND CODE SEGMENTS ARE ASSEMBLED             
00098100                                 %   IN THIS VECTOR                                 
00098200                                                                                    
00098300         LABELTABLE[0:LABELTABLELIMIT],                                             
00098400                                 % HOLDS VALUES OF LABELS ELSE POINTERS             
00098500                                                                                    
00098600         D1STACKTAGS[0:D1STACKLIMIT],                                               
00098700         D1STACK[0:D1STACKLIMIT],                                                   
00098800                                 % SEGMENT DICTIONARY IS BUILT IN HERE              
00098900                                                                                    
00099000         CODEBUF[0:29],          % CODE BUFFER TO WRITE TO FILE                     
00099100                                                                                    
00099200         T[0:1],                 % WORK VECTOR FOR UNPACK/PACK                      
00099300                                                                                    
00099400         NOOFSEGMENTS[0:2],      % COUNT NO OF EACH KIND SEGMENTS                   
00099500                                                                                    
00099600         ARRAYCELLS[0:31],       % EST MAX ARRAY CELLS AT LEX LVL                   
00099700                                                                                    
00099800         STACKCELLS[0:31];       % COUNTS HIGHEST CELL REFCD AT LEX LVL             
00099900                                                                                    
00100000 %=======================================================================           
00100100 %                                                                                  
00100200 % STATE INFORMATION                                                                
00100300 %                                                                                  
00100400 %=======================================================================           
00100500                                                                                    
00100600 INTEGER                                                                            
00100700                                                                                    
00100800         SEGTYPE,                % TYPE OF SEGMENT                                  
00100900                                                                                    
00101000         SEGNUMBER,              % INDEX INTO D1 STACK (SEG DICT)                   
00101100                                                                                    
00101200         SEGMENTBASE,            % BASE OF CURRENT SEGMENT INTO SEGBUF              
00101300                                                                                    
00101400         SEGSYLINDEX,            % SYLLABLE (0 TO 5) AND                            
00101500         SEGWORDINDEX,           % WORD POINTER TO NEXT FREE SYLLABLE               
00101600                                                                                    
00101700         LEXLEVEL,               % LEXICAL LEVEL OF THIS CODE SEGMENT               
00101800                                                                                    
00101900         DISKSECTOR,             % NEXT DISK SECTOR TO WRITE TO IN CODE             
00102000                                                                                    
00102100         LASTLABELALLOCATED,     % HIGHEST USED LABEL                               
00102200                                                                                    
00102300         LABELBASE,              % BASE OF CURRENT LABEL AREA                       
00102400                                                                                    
00102500         CODESIZE,               % NO OF WORDS OF CODE TOTAL                        
00102600                                                                                    
00102700         VALUEARRAYSIZE,         % NO OF WORDS IN VALUE ARRAYS TOTAL                
00102800                                                                                    
00102900         PARAMCOUNT,             % NO OF PARAMETERS TO MAIN PROGRAM                 
00103000                                                                                    
00103100         STARTSEG,               % START DISK SECTOR OF LAST SEG                    
00103200                                                                                    
00103300         LASTD1SLOTALLOCATED;    % HIGHEST USED SEG DICTIONARY ENTRY                
00103400                                                                                    
00103500 %=======================================================================           
00103600 %                                                                                  
00103700 % CODE FILE                                                                        
00103800 %                                                                                  
00103900 %=======================================================================           
00104000                                                                                    
00104100 FILE                                                                               
00104200         CODE(                                                                      
00104300                 KIND=DISK,                                                         
00104400                 UNITS=WORDS,                                                       
00104500                 MAXRECSIZE=30,                                                     
00104600                 BLOCKSIZE=150,                                                     
00104700                 AREASIZE=300,                                                      
00104800                 AREAS=20,                                                          
00104900                 BUFFERS=2,                                                         
00105000                 SAVEFACTOR=999);                                                   
00105100                                                                                    
00105200 DEFINE  CHUNK   =300#;          % MUST = CODE AREASIZE                             
00105300                                                                                    
00105400 %=======================================================================           
00105500 %                                                                                  
00105600 % ARRAY OF OPERATOR NAMES FOR PRIMARY MODE                                         
00105700 %                                                                                  
00105800 %=======================================================================           
00105900                                                                                    
00106000 REAL VALUE ARRAY OPNAME(                                                           
00106100         "ADD ","SUBT","MULT","DIVD","IDIV","RDIV","NTIA","NTGR",                   
00106200         "LESS","GREQ","GRTR","LSEQ","EQUL","NEQL","CHSN","MULX",                   
00106300         "LAND","LOR ","LNOT","LEQV","SAME","EH??","BSET","DBST",                   
00106400         "FLTR","DFTR","ISOL","DISO","INSR","DINS","BRST","DBRS",                   
00106500         "BRFL","BRTR","BRUN","EXIT","STBR","NXLN","INDX","RETN",                   
00106600         "DBFL","DBTR","DBUN","ENTR","EVAL","NXLV","MKST","STFF",                   
00106700         "ZERO","ONE ","LT8 ","LT16","PUSH","DLET","EXCH","DUPL",                   
00106800         "STOD","STON","OVRD","OVRN","EH??","LOAD","LT48","MPCW",                   
00106900         "SCLF","DSLF","SCRT","DSRT","SCRS","DSRS","SCRF","DSRF",                   
00107000         "SCRR","DSRR","ICVD","ICVU","SNGT","SNGL","XTND","IMKS",                   
00107100         "TEED","PACD","EXSD","TWSD","TWOD","SISO","SXSN","ROFF",                   
00107200         "TEEU","PACU","EXSU","TWSU","TWOU","EXPU","RTFF","HALT",                   
00107300         "TLSD","TGED","TGTD","TLED","TEQD","TNED","TUND","VMES",                   
00107400         "TLSU","TGEU","TGTU","TLEU","TEQU","TNEU","TUNU","VMEN",                   
00107500         "CLSD","CGED","CGTD","CLED","CEQD","CNED","EH??","EH??",                   
00107600         "CLSU","CGEU","CGTU","CLEU","CEQU","CNEU","NOOP","NVLD");                  
00107700                                                                                    
00107800 %=======================================================================           
00107900 %                                                                                  
00108000 % ARRAY OF OPERATOR NAMES FOR VARIANT MODE                                         
00108100 %                                                                                  
00108200 %=======================================================================           
00108300                                                                                    
00108400 REAL VALUE ARRAY VARNAME(                                                          
00108500         "EH??","EH??","JOIN","SPLT","IDLE","SINT","EEXI","DEXI",                   
00108600         "EH??","EH??","SCNI","SCNO","EH??","PTPA","WHOI","HEYU",                   
00108700         "EH??","EH??","EH??","EH??","EH??","EH??","EH??","EH??",                   
00108800         "EH??","EH??","EH??","EH??","EH??","EH??","EH??","EH??",                   
00108900         "EH??","EH??","EH??","EH??","EH??","EH??","EH??","EH??",                   
00109000         "EH??","EH??","EH??","EH??","EH??","EH??","EH??","EH??",                   
00109100         "EH??","EH??","EH??","EH??","EH??","EH??","EH??","EH??",                   
00109200         "EH??","EH??","EH??","EH??","EH??","EH??","EH??","EH??",                   
00109300         "EH??","EH??","EH??","EH??","EH??","OCRX","EH??","NTGD",                   
00109400         "EH??","EH??","EH??","LOG2","EH??","EH??","EH??","EH??",                   
00109500         "EH??","EH??","EH??","EH??","EH??","EH??","EH??","EH??",                   
00109600         "EH??","EH??","EH??","EH??","EH??","EH??","EH??","EH??",                   
00109700         "EH??","EH??","EH??","EH??","EH??","EH??","EH??","EH??",                   
00109800         "EH??","EH??","EH??","EH??","EH??","IRWL","PCWL","MVST",                   
00109900         "EH??","EH??","EH??","EH??","STAG","RTAG","RSUP","RSDN",                   
00110000         "RPRR","SPRR","RDLK","CBON","LODT","LLLU","SRCH","EH??",                   
00110100         "EH??","EH??","EH??","EH??","EH??","EH??","EH??","EH??",                   
00110200         "EH??","EH??","EH??","EH??","EH??","EH??","EH??","EH??",                   
00110300         "USND","UABD","TWFD","TWTD","SWFD","SWTD","EH??","TRNS",                   
00110400         "USNU","UABU","TWFU","TWTU","SWFU","SWTU","EH??","HALT",                   
00110500         "EH??","EH??","EH??","EH??","EH??","EH??","EH??","EH??",                   
00110600         "EH??","EH??","EH??","EH??","EH??","EH??","EH??","EH??",                   
00110700         "SLSD","SGED","SGTD","SLED","SEQD","SNED","EH??","EH??",                   
00110800         "SLSU","SGEU","SGTU","SLEU","SEQU","SNEU","NOOP","NVLD");                  
00110900                                                                                    
00111000 %=======================================================================           
00111100 %                                                                                  
00111200 % ARRAY OF OPERATOR NAMES FOR VECTOR MODE                                          
00111300 %                                                                                  
00111400 %=======================================================================           
00111500                                                                                    
00111600 REAL VALUE ARRAY VECNAME(                                                          
00111700         "LDA ","LDAI","LDB ","LDBI","LDC ","LDCI","VMEX","EH??",                   
00111800         "DLA ","DLAI","DLB ","DLBI","DLC ","DLCI","VEBR","EH??",                   
00111900         "STA ","STAI","STB ","STBI","STC ","STCI","EH??","EH??",                   
00112000         "DSA ","DSAI","DSB ","DSBI","DSC ","DSCI","EH??","EH??");                  
00112100                                                                                    
00112200 %=======================================================================           
00112300 %                                                                                  
00112400 % GENERAL DEFINES OF SYNTACTIC OBJECTS                                             
00112500 %                                                                                  
00112600 %=======================================================================           
00112700                                                                                    
00112800 DEFINE                                                                             
00112900         UPTO    =STEP 1 UNTIL#,                                                    
00113000         DOWNTO  =STEP -1 UNTIL#,                                                   
00113100         GOTO    =GO TO#;                                                           
00113200                                                                                    
00113300 %=======================================================================           
00113400 %                                                                                  
00113500 % SHORTHAND FOR CALLS OR COMPUTATION                                               
00113600 %                                                                                  
00113700 %=======================================================================           
00113800                                                                                    
00113900 DEFINE                                                                             
00114000         DEFADDRESS                                                                 
00114100                 =SEGNUMBER,(SEGWORDINDEX-SEGMENTBASE),SEGSYLINDEX#,                
00114200                                                                                    
00114300         DIGITSIN(NUMBER)                                                           
00114400                 =(((FIRSTONE(SCALERIGHTF(NUMBER,12))-1) DIV 4)+1)#,                
00114500                                                                                    
00114600         CERROR(ERRORNUMBER)                                                        
00114700                 =PACKAGEERROR(ERRORNUMBER,LINENUMBER)#;                            
00114800                                                                                    
00114900 %=======================================================================           
00115000 %                                                                                  
00115100 % DEFINES OF CONSTANTS OF PACKAGE 2                                                
00115200 %                                                                                  
00115300 %=======================================================================           
00115400                                                                                    
00115500 DEFINE                                                                             
00115600         LANGUAGE        =0#,    % MASQUERADE AS ALGOL FOR NOW                      
00115700                                                                                    
00115800         CAPABILITIES    =0#;    % NO IPC/DMS/SORT CAPABILITY                       
00115900                                                                                    
00116000 %=======================================================================           
00116100 %                                                                                  
00116200 % FIELD EXTRACTION DEFINES                                                         
00116300 %                                                                                  
00116400 %=======================================================================           
00116500                                                                                    
00116600 DEFINE                                                                             
00116700         BYTEMASK        =[7:8]#,        % LOW BYTE OF A WORD                       
00116800                                                                                    
00116900         HIGHBIT         =[47:1]#;       % TOPMOST BIT OF A WORD                    
00117000                                                                                    
00117100 %=======================================================================           
00117200 %                                                                                  
00117300 % DEFINES OF OPERATOR MNEMONICS FOR USE BY USER                                    
00117400 %                                                                                  
00117500 %=======================================================================           
00117600                                                                                    
00117700 DEFINE                                                                             
00117800     % VALUE AND NAME CALL OPERATORS                                                
00117900     VALC=0#,        NAMC=1#,                                                       
00118000                                                                                    
00118100     % PRIMARY MODE AND UNIVERSAL OPERATORS                                         
00118200     ADD =4"80"#,    SUBT=4"81"#,    MULT=4"82"#,    DIVD=4"83"#,                   
00118300     IDIV=4"84"#,    RDIV=4"85"#,    NTIA=4"86"#,    NTGR=4"87"#,                   
00118400     LESS=4"88"#,    GREQ=4"89"#,    GRTR=4"8A"#,    LSEQ=4"8B"#,                   
00118500     EQUL=4"8C"#,    NEQL=4"8D"#,    CHSN=4"8E"#,    MULX=4"8F"#,                   
00118600     LAND=4"90"#,    LOR =4"91"#,    LNOT=4"92"#,    LEQV=4"93"#,                   
00118700     SAME=4"94"#,                    BSET=4"96"#,    DBST=4"97"#,                   
00118800     FLTR=4"98"#,    DFTR=4"99"#,    ISOL=4"9A"#,    DISO=4"9B"#,                   
00118900     INSR=4"9C"#,    DINS=4"9D"#,    BRST=4"9E"#,    DBRS=4"9F"#,                   
00119000     BRFL=4"A0"#,    BRTR=4"A1"#,    BRUN=4"A2"#,    EXIT=4"A3"#,                   
00119100     STBR=4"A4"#,    NXLN=4"A5"#,    INDX=4"A6"#,    RETN=4"A7"#,                   
00119200     DBFL=4"A8"#,    DBTR=4"A9"#,    DBUN=4"AA"#,    ENTR=4"AB"#,                   
00119300     EVAL=4"AC"#,    NXLV=4"AD"#,    MKST=4"AE"#,    STFF=4"AF"#,                   
00119400     ZERO=4"B0"#,    ONE =4"B1"#,    LT8 =4"B2"#,    LT16=4"B3"#,                   
00119500     PUSH=4"B4"#,    DLET=4"B5"#,    EXCH=4"B6"#,    DUPL=4"B7"#,                   
00119600     STOD=4"B8"#,    STON=4"B9"#,    OVRD=4"BA"#,    OVRN=4"BB"#,                   
00119700                     LOAD=4"BD"#,    LT48=4"BE"#,    MPCW=4"BF"#,                   
00119800     SCLF=4"C0"#,    DSLF=4"C1"#,    SCRT=4"C2"#,    DSRT=4"C3"#,                   
00119900     SCRS=4"C4"#,    DSRS=4"C5"#,    SCRF=4"C6"#,    DSRF=4"C7"#,                   
00120000     SCRR=4"C8"#,    DSRR=4"C9"#,    ICVD=4"CA"#,    ICVU=4"CB"#,                   
00120100     SNGT=4"CC"#,    SNGL=4"CD"#,    XTND=4"CE"#,    IMKS=4"CF"#,                   
00120200     TEED=4"D0"#,    PACD=4"D1"#,    EXSD=4"D2"#,    TWSD=4"D3"#,                   
00120300     TWOD=4"D4"#,    SISO=4"D5"#,    SXSN=4"D6"#,    ROFF=4"D7"#,                   
00120400     TEEU=4"D8"#,    PACU=4"D9"#,    EXSU=4"DA"#,    TWSU=4"DB"#,                   
00120500     TWOU=4"DC"#,    EXPU=4"DD"#,    RTFF=4"DE"#,    HALT=4"DF"#,                   
00120600     TLSD=4"E0"#,    TGED=4"E1"#,    TGTD=4"E2"#,    TLED=4"E3"#,                   
00120700     TEQD=4"E4"#,    TNED=4"E5"#,    TUND=4"E6"#,    VMES=4"E7"#,                   
00120800     TLSU=4"E8"#,    TGEU=4"E9"#,    TGTU=4"EA"#,    TLEU=4"EB"#,                   
00120900     TEQU=4"EC"#,    TNEU=4"ED"#,    TUNU=4"EE"#,    VMEN=4"EF"#,                   
00121000     CLSD=4"F0"#,    CGED=4"F1"#,    CGTD=4"F2"#,    CLED=4"F3"#,                   
00121100     CEQD=4"F4"#,    CNED=4"F5"#,                                                   
00121200     CLSU=4"F8"#,    CGEU=4"F9"#,    CGTU=4"FA"#,    CLEU=4"FB"#,                   
00121300     CEQU=4"FC"#,    CNEU=4"FD"#,    NOOP=4"FE"#,    NVLD=4"FF"#,                   
00121400                                                                                    
00121500     % VARIANT MODE OPERATORS                                                       
00121600                                     JOIN=4"142"#,   SPLT=4"143"#,                  
00121700     IDLE=4"144"#,   SINT=4"145"#,   EEXI=4"146"#,   DEXI=4"147"#,                  
00121800                                     SCNI=4"14A"#,   SCNO=4"14B"#,                  
00121900                     PTPA=4"14D"#,   WHOI=4"14E"#,   HEYU=4"14F"#,                  
00122000                     OCRX=4"185"#,                   NTGD=4"187"#,                  
00122100                                                     LOG2=4"18B"#,                  
00122200                     IRWL=4"1AD"#,   PCWL=4"1AE"#,   MVST=4"1AF"#,                  
00122300     STAG=4"1B4"#,   RTAG=4"1B5"#,   RSUP=4"1B6"#,   RSDN=4"1B7"#,                  
00122400     RPRR=4"1B8"#,   SPRR=4"1B9"#,   RDLK=4"1BA"#,   CBON=4"1BB"#,                  
00122500     LODT=4"1BC"#,   LLLU=4"1BD"#,   SRCH=4"1BE"#,                                  
00122600     USND=4"1D0"#,   UABD=4"1D1"#,   TWFD=4"1D2"#,   TWTD=4"1D3"#,                  
00122700     SWFD=4"1D4"#,   SWTD=4"1D5"#,                   TRNS=4"1D7"#,                  
00122800     USNU=4"1D8"#,   UABU=4"1D9"#,   TWFU=4"1DA"#,   TWTU=4"1DB"#,                  
00122900     SWFU=4"1DC"#,   SWTU=4"1DD"#,                                                  
00123000     SLSD=4"1F0"#,   SGED=4"1F1"#,   SGTD=4"1F2"#,   SLED=4"1F3"#,                  
00123100     SEQD=4"1F4"#,   SNED=4"1F5"#,                                                  
00123200     SLSU=4"1F8"#,   SGEU=4"1F9"#,   SGTU=4"1FA"#,   SLEU=4"1FB"#,                  
00123300     SEQU=4"1FC"#,   SNEU=4"1FD"#,                                                  
00123400                                                                                    
00123500     % EDIT MODE OPERATORS                                                          
00123600     MINS=4"2D0"#,   MFLT=4"2D1"#,   SFSC=4"2D2"#,   SRSC=4"2D3"#,                  
00123700     RSTF=4"2D4"#,   ENDF=4"2D5"#,   MVNU=4"2D6"#,   MCHR=4"2D7"#,                  
00123800     INOP=4"2D8"#,   INSG=4"2D9"#,   SFDC=4"2DA"#,   SRDC=4"2DB"#,                  
00123900     INSU=4"2DC"#,   INSC=4"2DD"#,   ENDE=4"2DE"#,                                  
00124000                                                                                    
00124100     % VECTOR MODE OPERATORS                                                        
00124200     FTCH=2#,        STOR=3#,                                                       
00124300     LDA =4"4E0"#,   LDAI=4"4E1"#,   LDB =4"4E2"#,   LDBI=4"4E3"#,                  
00124400     LDC =4"4E4"#,   LDCI=4"4E5"#,   VMEX=4"4E6"#,                                  
00124500     DLA =4"4E8"#,   DLAI=4"4E9"#,   DLB =4"4EA"#,   DLBI=4"4EB"#,                  
00124600     DLC =4"4EC"#,   DLCI=4"4ED"#,   VEBR=4"4EE"#,                                  
00124700     STA =4"4F0"#,   STAI=4"4E1"#,   STB =4"4E2"#,   STBI=4"4F3"#,                  
00124800     STC =4"4F4"#,   STCI=4"4F5"#,                                                  
00124900     DSA =4"4F8"#,   DSAI=4"4F9"#,   DSB =4"4FA"#,   DSBI=4"4FB"#,                  
00125000     DSC =4"4FC"#,   DSCI=4"4FD"#;                                                  
00125100                                                                                    
00125200 %=======================================================================           
00125300 %                                                                                  
00125400 % DEFINES OF PARAMETERS FOR SEGMENT TYPES (BEGINNEWSEGMENT)                        
00125500 %                                                                                  
00125600 %=======================================================================           
00125700                                                                                    
00125800 DEFINE                                                                             
00125900         CODESEGTYPE     =0#,    % A CODE SEGMENT                                   
00126000         WORDSEGTYPE     =1#,    % VALUE ARRAY OF SINGLE WORDS                      
00126100         DOUBLESEGTYPE   =2#,    % VALUE ARRAY OF DOUBLE-WORDS                      
00126200         INFOSEGTYPE     =3#;    % DATA WHICH IS NOT IN D1STACK                     
00126300                                                                                    
00126400 %=======================================================================           
00126500 %                                                                                  
00126600 % FORMAT DECLARATIONS FOR USE IN CODE GENERATION                                   
00126700 %   ACCUMULATED FOR EFFICIENCY IN STORAGE AND ACCESS                               
00126800 %                                                                                  
00126900 %=======================================================================           
00127000                                                                                    
00127100 DEFINE                                                                             
00127200         FORMATADDRESS =                                                            
00127300           REPLACE H[0] BY SEGNUMBER.[11:48] FOR 3,                                 
00127400             (SEGWORDINDEX-SEGMENTBASE).[15:48] FOR 4,                              
00127500             SEGSYLINDEX.[3:48] FOR 1;                                              
00127600           REPLACE LBUF0 BY " " FOR 40,                                             
00127700             H[0] FOR 3 WITH HEXTOEBCDIC,                                           
00127800             ":",                                                                   
00127900             H[3] FOR 4 WITH HEXTOEBCDIC,                                           
00128000             ":",                                                                   
00128100             H[7] FOR 1 WITH HEXTOEBCDIC;#,                                         
00128200                                                                                    
00128300         FORMATPRIMARY(A) =                                                         
00128400           FORMATADDRESS;                                                           
00128500           REPLACE LBUF0+60 BY A.[31:48] FOR 4;#,                                   
00128600                                                                                    
00128700         FORMATWORD(A) =                                                            
00128800           REPLACE H[0] BY                                                          
00128900             SEGNUMBER.[11:48] FOR 3,                                               
00129000             (SEGWORDINDEX-SEGMENTBASE).[15:48] FOR 4;                              
00129100           REPLACE LBUF0 BY                                                         
00129200             H[0] FOR 3 WITH HEXTOEBCDIC,                                           
00129300             ":",                                                                   
00129400             H[3] FOR 4 WITH HEXTOEBCDIC,                                           
00129500             ":0   ";                                                               
00129600           REPLACE H[0] BY A FOR 12;                                                
00129700           REPLACE LBUF0 + 14 BY H FOR 12 WITH HEXTOEBCDIC;#;                       
00129800                                                                                    
00129900 %***********************************************************************           
00130000 %***********************************************************************           
00130100 %**                                                                   **           
00130200 %**     (C) COPYRIGHT 1976  A.H.J.SALE AND R.A.FREAK                  **           
00130300 %**             HOBART, TASMANIA                                      **           
00130400 %**                                                                   **           
00130500 %**     NOT TO BE REPRODUCED IN WHOLE OR IN PART                      **           
00130600 %**     WITHOUT WRITTEN PERMISSION FROM THE AUTHORS:                  **           
00130700 %**             C/0 DEPARTMENT OF INFORMATION SCIENCE                 **           
00130800 %**             UNIVERSITY OF TASMANIA                                **           
00130900 %**             BOX 252C, G.P.O., HOBART                              **           
00131000 %**             TASMANIA  7001                                        **           
00131100 %**                                                                   **           
00131200 %**     ALL RIGHTS RESERVED                                           **           
00131300 %**                                                                   **           
00131400 %**     PACKAGE1                                                      **           
00131500 %**     -------                                                       **           
00131600 %**     IMPLEMENTS A BURROUGHS COMPATIBLE INPUT INTERFACE             **           
00131700 %**     WITH PROCESSING OF CARD/TAPE/NEWTAPE/INCLUDE FILES            **           
00131800 %**     AND OF COMPILER OPTIONS.                                      **           
00131900 %**                                                                   **           
00132000 %**     USER-MODIFIABLE TO PARTICULAR COMPILER NEEDS.                 **           
00132100 %**     THIS VERSION FOR B6700 PASCAL COMPILER.                       **           
00132200 %**                                                                   **           
00132300 %***********************************************************************           
00132400 %***********************************************************************           
00132500 %***********************************************************************           
00132600 %                                                                                  
00132700 % COMPILER PACKAGE VERSION 1.0  -INPUT ROUTINES-                                   
00132800 %                                                                                  
00132900 % GLOBAL DATA SEGMENT                                                              
00133000 %                                                                                  
00133100 % (C) COPYRIGHT                                                                    
00133200 % R.A.FREAK AND A.H.J.SALE                                                         
00133300 % DEPARTMENT OF INFORMATION SCIENCE                                                
00133400 % UNIVERSITY OF TASMANIA                                                           
00133500 % HOBART                                                                           
00133600 %                                                                                  
00133700 % JULY 1976                                                                        
00133800 %                                                                                  
00133900 % USER INTERFACE AND USER MODIFIABLE                                               
00134000 %                                                                                  
00134100 %***********************************************************************           
00134200                                                                                    
00134300                                                                                    
00134400 %***********************************************************************           
00134500 %                                                                                  
00134600 % COMPILER OPTION FLAGS                                                            
00134700 %                                                                                  
00134800 %***********************************************************************           
00134900                                                                                    
00135000 DEFINE                                                                             
00135100          USERARRAYSIZE=100#; %SIZE OF USER OPTION ARRAY                            
00135200                                                                                    
00135300 BOOLEAN                      %IF TRUE THIS MEANS:-                                 
00135400          BOUNDSCHECKTOG,     %BOUNDS CHECKING CARRIED OUT                          
00135500          CHECKTOG,           %CHECK FOR SEQUENCE ERRORS                            
00135600          CODETOG,            %PRODUCE COMPILER-GENERATED OBJECT CODE               
00135700          ERRLISTTOG,         %PRODUCE ERROR LISTING FOR CANDE CALL                 
00135800          INCLNEWTOG,         %INCLUDED TEXT OUTPUT TO NEWTAPE FILE                 
00135900          DOLLARTOG,          %PRINT DOLLAR CARDS                                   
00136000          LISTTOG,            %SOURCE PROGRAM LISTING REQUIRED                      
00136100          LISTINCLTOG,        %LISTING OF INCLUDED FILES DESIRED                    
00136200          MERGETOG,           %MERGING WITH TAPE SOURCE FILE                        
00136300          NEWTOG,             %NEW SOURCE TAPE DESIRED                              
00136400          OMITTING,           %CURRENTLY OMITTING CARDS AND TAPE                    
00136500          SEQTOG,             %NEW SEQUENCE NOS ON NEWTAPE DESIRED                  
00136600          NAMESTOG,           %PRINTOUT CONTAINS STACK ADDRESSES                    
00136700          HEXCODETOG,         %PRINT HEX CODE                                       
00136800          LINEINFOTOG,        %PRODUCE LINE INFORMATION                             
00136900          ASCIITOG,           %STRINGS STORED IN ASCII                              
00137000          XREFTOG,            %PRODUCE CROSS REFERENCE LISTING                      
00137100          TRUSTWORTHYTOG,     %PRODUCE FASTER CODE                                  
00137200          WARNINGSTOG,        %NO WARNING MESSAGES PRODUCED                         
00137300          STANDARDTOG,        %STRICTLY STANDARD PASCAL                             
00137400          STATISTICSTOG,      %COLLECT PROFILE STATISTICS                           
00137500          STRIPBLANKSTOG,     %STRIP TRAILING BLANKS IN TEXT FILES                  
00137600          BINDINFOTOG,        %PRODUCE BINDINFO                                     
00137700          AUTOBINDTOG;        %AUTOMATICALLY CALL BINDER                            
00137800                                                                                    
00137900 INTEGER                                                                            
00138000 %        NOOFERRORS,         %NUMBER OF ERRORS ENCOUNTERED                         
00138100          ERRORCOUNT,         %NUMBER OF ERRORS ALLOWED                             
00138200          MAXSETSIZE,         %SET SIZE FOR EXPRESSIONS                             
00138300          HEAPSIZE;           %SIZE OF HEAP                                         
00138400                                                                                    
00138500 ARRAY                                                                              
00138600          USEROPTIONS[0:USERARRAYSIZE];  %USEROPTIONS - STRUCTURE                   
00138700                              %WORD[0].[47:8]- NO. CHARS IN NAME                    
00138800                              %WORD[0].[40:NO.CHARS]- NAME OF USER OPTION           
00138900                              %NEXT AVAILABLE WORD - TOGGLE FOR OPTION              
00139000                                                                                    
00139100 %***********************************************************************           
00139200 %                                                                                  
00139300 % FILES                                                                            
00139400 %                                                                                  
00139500 %***********************************************************************           
00139600                                                                                    
00139700 DEFINE                                                                             
00139800    DISKFILE=FILETYPE=8,MAXRECSIZE=14,INTMODE=EBCDIC,KIND=1,                        
00139900             BLOCKSIZE=150,BUFFERS=2 #;                                             
00140000                                                                                    
00140100 FILE                                                                               
00140200    CARD   (KIND=9,FILETYPE=8,BUFFERS=2,INTMODE=EBCDIC),                            
00140300    TAPE   (KIND=1,FILETYPE=8,BUFFERS=2,INTMODE=EBCDIC),                            
00140400    NEWTAPE(INTMODE=EBCDIC,KIND=1,AREAS=60,AREASIZE=1000,                           
00140500            BUFFERS=2,MAXRECSIZE=15,BLOCKSIZE=450,                                  
00140600            SAVEFACTOR=999),                                                        
00140700    LINE   (INTMODE=4,KIND=7,BUFFERS=2,MAXRECSIZE=22),                              
00140800 %  LINE(KIND=REMOTE,MAXRECSIZE=22),                                                
00140900    ERRORFILE(KIND=7,BUFFERS=3,MAXRECSIZE=12),                                      
00141000    INCL0  (DISKFILE),                                                              
00141100    INCL1  (DISKFILE),                                                              
00141200    INCL2  (DISKFILE),                                                              
00141300    INCL3  (DISKFILE),                                                              
00141400    INCL4  (DISKFILE);                                                              
00141500                                                                                    
00141600 SWITCH FILE INCL:= INCL0,INCL1,INCL2,INCL3,INCL4;                                  
00141700                                                                                    
00141800 %***********************************************************************           
00141900 %                                                                                  
00142000 %  GLOBAL VARIABLES AND DECLARATIONS                                               
00142100 %                                                                                  
00142200 %***********************************************************************           
00142300                                                                                    
00142400                                                                                    
00142500 DEFINE                                                                             
00142600   INCLMAX = 4#,               %NESTING LEVEL FOR $INCLUDE                          
00142700   MAXINTEGER = 100000000#,    %MAX CARD SEQ NO+1                                   
00142800   CARDSIZE = 80#,             %CHARACTERS PER CARD IMAGE                           
00142900   CARDWORDSIZE = 14#,         %WORDS PER CARD IMAGE                                
00143000   INCLSZ = 3#,                %NO WORDS IN INCLDIR ENTRY                           
00143100   VALIDBIT = [47:1]#,                                                              
00143200   INCLFILE = INCL[INCLX]#,                                                         
00143300   CARDBUFF0 = POINTER(CARDBUFF)#,                                                  
00143400   TAPEBUFF0 = POINTER(TAPEBUFF)#,                                                  
00143500   CARDBUFF73 = POINTER(CARDBUFF)+72 #,                                             
00143600   TAPEBUFF73 = POINTER(TAPEBUFF)+72#,                                              
00143700   PLINEBUFF = POINTER(LINEBUFF)#,                                                  
00143800   PERRORBUFF = POINTER(ERRORBUFF)#,                                                
00143900   LASTSEQUENCE = POINTER(GARBAGE)#,                                                
00144000   ERRSEQUENCE = POINTER(GARBAGE)+8#;                                               
00144100                                                                                    
00144200 INTEGER                                                                            
00144300   LASTUSED,                    %WHERE LAST IMAGE CAME FROM                         
00144400                                %0-INCLUDE FILE,1-CARD,5-TAPE                       
00144500                                %MERGE:2-CARD,3-EQUAL TAKE CARD,4-TAPE              
00144600   SAVELASTUSED,                %SAVE LASTUSED WHEN INCLUDING                       
00144700   SAVEINCLSEQ,                 %SAVE INCLSEQ FROM PRIMARY SOURCE                   
00144800   SEQERRORS,                   %NO. SEQUENCE ERRORS                                
00144900   LINECOUNT,                   %LINES WRITTEN                                      
00145000 % CARDCOUNT,                   %CARDS READ                                         
00145100   INCLX,                       %INDICATES INCLUDED FILE BEING USED                 
00145200   STOPINCLSEQ,                 %SEQUENCE NO TO STOP AT ON INCLUDE FILE             
00145300 % INCLSEQ,                     %CURRENT SEQUENCE NO                                
00145400   LASTINCLSEQ,                 %LAST SEQ NO USED FROM INCLUDE FILE                 
00145500   RESEQINC,                    %INCREMENT WHEN RESEQUENCING                        
00145600   RESEQNO;                     %NEXT SEQUENCE NO WHEN RESEQUENCING                 
00145700                                                                                    
00145800 BOOLEAN                       %WHEN TRUE :-                                        
00145900    HEADINGPRINTED,            %HEADING HAS BEEN PRINTED                            
00146000    CANDETOG,                  %CALLED FROM CANDE                                   
00146100    TAPERES,                   %TAPE FILE CURRENTLY OPEN                            
00146200    STARTINCL,                 %START INCLUDING                                     
00146300    VALIDINCLBUFF;             %VALID INCLUDE BUFFER                                
00146400                                                                                    
00146500 REAL ARRAY                                                                         
00146600   GARBAGE[0:2],               %FIRST 8 CHARS = LAST SEQUENCE NO.                   
00146700   INCLDIR[0:(INCLMAX+1)*INCLSZ];  %INCLUDE SAVED DIRECTORY                         
00146800                               %1-CURRENT SEQ NO, 2-STOP SEQ NO                     
00146900                               %3-LAST SEQ NO                                       
00147000 HEX ARRAY                                                                          
00147100   H[0:15];                     %USED IN MAKING CODE ADDRESSES                      
00147200                                                                                    
00147300 POINTER                                                                            
00147400   NEXTCHAR,                    %NEXT CHAR TO BE SCANNED IN BUFFER                  
00147500   LASTCHAR,                    %LAST CHAR(+1) TO BE SCANNED IN BUFFER              
00147600   PINCLBUFF0,                  %START OF CURRENT INCLUDE BUFFER                    
00147700   PINCLBUFF73;                 %END OF CURRENT INCLUDE BUFFER                      
00147800                                                                                    
00147900 %***********************************************************************           
00148000 %                                                                                  
00148100 %  FILE BUFFERS                                                                    
00148200 %                                                                                  
00148300 %***********************************************************************           
00148400                                                                                    
00148500 ALPHA ARRAY                                                                        
00148600   CARDBUFF[0:13],           %CARD IMAGE FROM "CARD"                                
00148700   ERRORBUFF[0:30],          %OPTERROR LISTING BUFFER                               
00148800   INCLBUFF[0:INCLMAX,0:13], %INCLUDE TEXT BUFFERS                                  
00148900   LINEBUFF[0:22],           %LIME IMAGE                                            
00149000   TAPEBUFF[0:13];           %CARD IMAGE FROM "TAPE"                                
00149100                                                                                    
00149200 %***********************************************************************           
00149300 %                                                                                  
00149400 %  FORWARD PROCEDURE DECLARATIONS                                                  
00149500 %                                                                                  
00149600 %***********************************************************************           
00149700                                                                                    
00149800 PROCEDURE WRITENEXTNEWTAPE(A,B);                                                   
00149900 VALUE A,B;                                                                         
00150000 POINTER A;                                                                         
00150100 BOOLEAN B;                                                                         
00150200 FORWARD;                                                                           
00150300                                                                                    
00150400 PROCEDURE ANALYSEOPTION;                                                           
00150500 FORWARD;                                                                           
00150600                                                                                    
00150700 PROCEDURE OPTERROR(B,A);                                                           
00150800 VALUE A,B;                                                                         
00150900 POINTER B;                                                                         
00151000 INTEGER A;                                                                         
00151100 FORWARD;                                                                           
00151200                                                                                    
00151300 BOOLEAN PROCEDURE READINCLUDE;                                                     
00151400 FORWARD;                                                                           
00151500                                                                                    
00151600 PROCEDURE WRITELINE;                                                               
00151700 FORWARD;                                                                           
00151800                                                                                    
00151900 PROCEDURE EDITLINE(P);                                                             
00152000 VALUE P;                                                                           
00152100 POINTER P;                                                                         
00152200 FORWARD;                                                                           
00152300                                                                                    
00152400 PROCEDURE HEADING;                                                                 
00152500 FORWARD;                                                                           
00152600                                                                                    
00152700 PROCEDURE ERROR(NO);                                                               
00152800 VALUE NO;                                                                          
00152900 INTEGER NO;                                                                        
00153000 FORWARD;                                                                           
00153100                                                                                    
00153200 %***********************************************************************           
00153300 %                                                                                  
00153400 % PROCEDURAL DEFINES OF GENERAL USE                                                
00153500 %                                                                                  
00153600 %***********************************************************************           
00153700                                                                                    
00153800 DEFINE                                                                             
00153900   DELTA(P,Q) = ((REAL(Q).[35:16] - REAL(P).[35:16])*6                              
00154000     +REAL(Q).[39:4]-REAL(P).[39:4])#,                                              
00154100                                                                                    
00154200   CHECKERRORLIMIT = BEGIN                                                          
00154300     IF (NOOFERRORS >= ERRORCOUNT) AND (ERRORCOUNT NEQ 0) THEN BEGIN                
00154400       IF CANDETOG THEN                                                             
00154500         REPLACE PLINEBUFF BY " ERROR LIMIT EXCEEDED "                              
00154600       ELSE BEGIN                                                                   
00154700         REPLACE PLINEBUFF BY "*" FOR 17 WORDS;                                     
00154800         REPLACE PLINEBUFF+45 BY " ERROR LIMIT EXCEEDED ";                          
00154900       END;                                                                         
00155000       IF ERRLISTTOG THEN WRITE(ERRORFILE,12,LINEBUFF[*]);                          
00155100       WRITELINE;                                                                   
00155200       GO TO SHEERANDUTTERDISASTER;                                                 
00155300     END;                                                                           
00155400   END#;                                                                            
00155500 %***********************************************************************           
00155600 %                                                                                  
00155700 %  READ NEXT LINE OF COMPILER INPUT                                                
00155800 %  ANALYSE $ CARDS                                                                 
00155900 %  WRITE LINE TO NEWTAPE FILE                                                      
00156000 %                                                                                  
00156100 %                                                                                  
00156200 %  R.A.FREAK                                                                       
00156300 %  DEPARTMENT OF INFORMATION SCIENCE                                               
00156400 %  UNIVERSITY OF TASMANIA                                                          
00156500 %  HOBART                                                                          
00156600 %                                                                                  
00156700 %  JULY 1976                                                                       
00156800 %                                                                                  
00156900 %***********************************************************************           
00157000                                                                                    
00157100 BOOLEAN PROCEDURE READNEXTLINE(LINEIMAGE);                                         
00157200 ARRAY LINEIMAGE[*];                                                                
00157300 BEGIN                                                                              
00157400 LABEL                                                                              
00157500   EOFCARD,EOFTAPE,                                                                 
00157600   STARTREAD,EXIT,                                                                  
00157700   READTAPE,COMPARE,                                                                
00157800   EOFBOTH,CHECKDOLLAR;                                                             
00157900                                                                                    
00158000 %***********************************************************************           
00158100 %                                                                                  
00158200 % DEFINES OF GENERAL USE                                                           
00158300 %                                                                                  
00158400 %***********************************************************************           
00158500                                                                                    
00158600 DEFINE                                                                             
00158700   PRINTERRFILE= BEGIN                                                              
00158800     REPLACE POINTER(ERRORBUFF) BY LASTCHAR-72 FOR 72;                              
00158900     WRITE(ERRORFILE,12,ERRORBUFF[*]);                                              
00159000   END;#,                                                                           
00159100                                                                                    
00159200   PRINTCARD = BEGIN                                                                
00159300     EDITLINE(LASTCHAR-72);                                                         
00159400     WRITELINE;                                                                     
00159500   END;#;                                                                           
00159600                                                                                    
00159700 %***********************************************************************           
00159800 %                                                                                  
00159900 %  PROCEDURES OF GENERAL USE                                                       
00160000 %                                                                                  
00160100 %***********************************************************************           
00160200                                                                                    
00160300 PROCEDURE STOPINCLUDING;                                                           
00160400 BEGIN                                                                              
00160500   LABEL                                                                            
00160600     EXIT;                                                                          
00160700   INTEGER                                                                          
00160800     I;                                                                             
00160900   INCLDIR[I:=INCLX*INCLSZ]:=INCLSEQ;                                               
00161000   INCLDIR[I+1]:=STOPINCLSEQ & REAL(VALIDINCLBUFF) VALIDBIT;                        
00161100   INCLDIR[I+2]:= LASTINCLSEQ;                                                      
00161200   IF (INCLX:=*-1 LSS 0) THEN BEGIN                                                 
00161300     LASTUSED:=SAVELASTUSED;                                                        
00161400     INCLSEQ:=SAVEINCLSEQ;                                                          
00161500     GO TO EXIT;                                                                    
00161600   END;                                                                             
00161700   VALIDINCLBUFF:=FALSE;                                                            
00161800   INCLSEQ:=INCLDIR[I:=INCLX*INCLSZ];                                               
00161900   STOPINCLSEQ:=INCLDIR[I+1];                                                       
00162000   LASTINCLSEQ:= INCLDIR[I+2];                                                      
00162100   PINCLBUFF0:= POINTER(INCLBUFF[INCLX,*]);                                         
00162200   PINCLBUFF73:=POINTER(INCLBUFF[INCLX,*])+72;                                      
00162300 EXIT:                                                                              
00162400   REPLACE LASTSEQUENCE BY INCLSEQ FOR 8 DIGITS;                                    
00162500 END;                                                                               
00162600                                                                                    
00162700 %***********************************************************************           
00162800 %                                                                                  
00162900 %  MAIN SECTION OF READNEXTLINE                                                    
00163000 %                                                                                  
00163100 %***********************************************************************           
00163200 STARTREAD:                                                                         
00163300   IF (LASTUSED=0) THEN BEGIN             %SOURCE IS INCLUDE FILE                   
00163400     NEXTCHAR:=PINCLBUFF0;                                                          
00163500     LASTCHAR:=PINCLBUFF73;                                                         
00163600     IF VALIDINCLBUFF THEN VALIDINCLBUFF:=FALSE                                     
00163700     ELSE IF READINCLUDE THEN BEGIN                                                 
00163800       STOPINCLUDING;                                                               
00163900       GO TO STARTREAD;                                                             
00164000     END;                                                                           
00164100     IF (STOPINCLSEQ LSS INCLSEQ) THEN BEGIN                                        
00164200       STOPINCLUDING;                                                               
00164300       GO TO STARTREAD;                                                             
00164400     END;                                                                           
00164500     VALIDINCLBUFF:=FALSE;                                                          
00164600     GO TO CHECKDOLLAR;                                                             
00164700   END;                                                                             
00164800   IF (LASTUSED LEQ 3) THEN BEGIN         %SOURCE IS CARD                           
00164900     READ(CARD,CARDSIZE,CARDBUFF[*]) [EOFCARD];                                     
00165000   END;                                                                             
00165100 READTAPE:                                                                          
00165200   IF (LASTUSED GEQ 3) THEN BEGIN         %SOURCE IS TAPE                           
00165300     READ(TAPE,CARDSIZE,TAPEBUFF[*]) [EOFTAPE];                                     
00165400   END;                                                                             
00165500 COMPARE:                                                                           
00165600   IF (LASTUSED = 1) THEN BEGIN           %SELECT TAPE OR CARD                      
00165700     NEXTCHAR:= CARDBUFF0;                                                          
00165800     LASTCHAR:=CARDBUFF73;                                                          
00165900   END ELSE                                                                         
00166000   IF (LASTUSED = 5) THEN BEGIN                                                     
00166100     NEXTCHAR:=TAPEBUFF0;                                                           
00166200     LASTCHAR:=TAPEBUFF73;                                                          
00166300   END ELSE                                                                         
00166400   IF(CARDBUFF73 > TAPEBUFF73 FOR 8) THEN BEGIN                                     
00166500     NEXTCHAR:= TAPEBUFF0;                                                          
00166600     LASTCHAR:= TAPEBUFF73;                                                         
00166700     LASTUSED:=4;                                                                   
00166800   END ELSE BEGIN                                                                   
00166900     NEXTCHAR:= CARDBUFF0;                                                          
00167000     LASTCHAR:=CARDBUFF73;                                                          
00167100     LASTUSED:= IF (CARDBUFF73 = TAPEBUFF73 FOR 8) THEN 3 ELSE 2;                   
00167200   END;                                                                             
00167300                                                                                    
00167400   IF CHECKTOG THEN BEGIN                 %SEQUENCE CHECK                           
00167500     IF (LASTSEQUENCE > LASTCHAR FOR 8) THEN BEGIN                                  
00167600       SEQERRORS:=*+1;                                                              
00167700       REPLACE LINEBUFF+116 BY " SEQERR ",                                          
00167800         LASTSEQUENCE FOR 8;                                                        
00167900       IF ERRLISTTOG THEN BEGIN                                                     
00168000         PRINTERRFILE;                                                              
00168100         REPLACE PERRORBUFF BY LASTCHAR FOR 8,                                      
00168200           PLINEBUFF+116 FOR 16,                                                    
00168300           " " FOR 48;                                                              
00168400         WRITE(ERRORFILE,12,ERRORBUFF[*]);                                          
00168500       END;                                                                         
00168600     END;                                                                           
00168700   END;                                                                             
00168800 CHECKDOLLAR:                                                                       
00168900   REPLACE LASTSEQUENCE BY LASTCHAR FOR 8;                                          
00169000   INCLSEQ:= INTEGER(LASTSEQUENCE,8);                                               
00169100   IF ((NEXTCHAR = "$" FOR 1) OR (NEXTCHAR = " $" FOR 2)) THEN BEGIN                
00169200     ANALYSEOPTION;                                                                 
00169300     IF STARTINCL THEN BEGIN                                                        
00169400       STARTINCL:=FALSE;                                                            
00169500       GO TO STARTREAD;                                                             
00169600     END;                                                                           
00169700     IF (DOLLARTOG AND LISTTOG) THEN PRINTCARD;                                     
00169800     GO TO STARTREAD;                                                               
00169900   END;                                                                             
00170000                                                                                    
00170100   IF SEQTOG THEN BEGIN                                                             
00170200     REPLACE LASTCHAR BY RESEQNO FOR 8 DIGITS;                                      
00170300     RESEQNO:= *+RESEQINC;                                                          
00170400   END;                                                                             
00170500                                                                                    
00170600   IF NEWTOG THEN BEGIN                                                             
00170700     IF (LASTUSED NEQ 0) THEN BEGIN                                                 
00170800       WRITENEXTNEWTAPE(NEXTCHAR,FALSE);                                            
00170900     END ELSE                                                                       
00171000       IF INCLNEWTOG THEN WRITENEXTNEWTAPE(NEXTCHAR,FALSE);                         
00171100   END;                                                                             
00171200                                                                                    
00171300   IF LISTTOG THEN BEGIN                                                            
00171400     IF (LASTUSED = 0) THEN BEGIN                                                   
00171500       IF LISTINCLTOG THEN PRINTCARD;                                               
00171600     END ELSE BEGIN                                                                 
00171700       PRINTCARD;                                                                   
00171800     END;                                                                           
00171900   END;                                                                             
00172000   CARDCOUNT:=*+1;                                                                  
00172100   IF OMITTING THEN GO TO STARTREAD;                                                
00172200   READNEXTLINE:= FALSE;                                                            
00172300   REPLACE POINTER(LINEIMAGE) BY NEXTCHAR FOR 80;                                   
00172400   GO TO EXIT;                                                                      
00172500                                                                                    
00172600 EOFCARD:                                                                           
00172700   IF (LASTUSED = 1) THEN BEGIN                                                     
00172800 EOFBOTH:                                                                           
00172900     IF NEWTOG THEN BEGIN                                                           
00173000       WRITENEXTNEWTAPE(CARDBUFF,TRUE);                                             
00173100     END;                                                                           
00173200     READNEXTLINE:=TRUE;                                                            
00173300     GO TO EXIT;                                                                    
00173400   END ELSE BEGIN                                                                   
00173500     IF (LASTUSED = 3) THEN BEGIN                                                   
00173600       LASTUSED:=5;                                                                 
00173700       GO TO READTAPE;                                                              
00173800     END ELSE BEGIN                                                                 
00173900       LASTUSED:=5;                                                                 
00174000     END;                                                                           
00174100       GO TO COMPARE;                                                               
00174200   END;                                                                             
00174300 EOFTAPE:                                                                           
00174400   IF (LASTUSED = 5) THEN GO TO EOFBOTH;                                            
00174500   CLOSE (TAPE);                                                                    
00174600   LASTUSED:=1;                                                                     
00174700   GO TO COMPARE;                                                                   
00174800 EXIT:                                                                              
00174900 END;                                                                               
00175000                                                                                    
00175100 %***********************************************************************           
00175200 %                                                                                  
00175300 %  INITIALIZE OPTION INFORMATION - MODIFIABLE FOR EACH APPLICATION                 
00175400 %                                                                                  
00175500 %  R.A.FREAK                                                                       
00175600 %  DEPARTMENT OF INFORMATION SCIENCE                                               
00175700 %  UNIVERSITY OF TASMANIA                                                          
00175800 %  HOBART                                                                          
00175900 %                                                                                  
00176000 %  JULY 1976                                                                       
00176100 %                                                                                  
00176200 %***********************************************************************           
00176300                                                                                    
00176400 PROCEDURE INITIALIZEOPTIONINFO;                                                    
00176500 BEGIN                                                                              
00176600   CHECKTOG:=                                                                       
00176700   CODETOG:=                                                                        
00176800   ERRLISTTOG:=                                                                     
00176900   INCLNEWTOG:=                                                                     
00177000   DOLLARTOG:=                                                                      
00177100   LISTINCLTOG:=                                                                    
00177200   MERGETOG:=                                                                       
00177300   NEWTOG:=                                                                         
00177400   OMITTING:=                                                                       
00177500   SEQTOG:=                                                                         
00177600   NAMESTOG:=                                                                       
00177700   HEXCODETOG:=                                                                     
00177800   ASCIITOG:=                                                                       
00177900   XREFTOG:=                                                                        
00178000   TRUSTWORTHYTOG:=                                                                 
00178100   STANDARDTOG:=                                                                    
00178200   STATISTICSTOG:=                                                                  
00178300   BINDINFOTOG:=                                                                    
00178400   AUTOBINDTOG:=                                                                    
00178500     FALSE;                                                                         
00178600   LISTTOG:=                                                                        
00178700   WARNINGSTOG:=                                                                    
00178800   LINEINFOTOG:=                                                                    
00178900   STRIPBLANKSTOG:=                                                                 
00179000   BOUNDSCHECKTOG:=                                                                 
00179100     TRUE;                                                                          
00179200   ERRORCOUNT:=                                                                     
00179300     150;                                                                           
00179400   CANDETOG:=BOOLEAN(SEGZERO[0].[47:1]);                                            
00179500   IF CANDETOG THEN BEGIN                                                           
00179600     ERRLISTTOG:=TRUE;                                                              
00179700     LISTTOG:=FALSE;                                                                
00179800     ERRORCOUNT:=6;                                                                 
00179900   END;                                                                             
00180000   MAXSETSIZE:=                                                                     
00180100     47;                                                                            
00180200   HEAPSIZE:=                                                                       
00180300     1000;                                                                          
00180400   NOOFERRORS:=0;                                                                   
00180500 %***********************************************************************           
00180600 %  INITIALIZE SECTION - NOT USER MODIFIABLE                                        
00180700 %***********************************************************************           
00180800   INCLX:= -1;                                                                      
00180900   LASTUSED:=1;                                                                     
00181000   REPLACE PLINEBUFF BY " " FOR 22 WORDS;                                           
00181100   RESEQNO:= RESEQINC:= 100;                                                        
00181200   REPLACE ERRSEQUENCE BY " " FOR 8;                                                
00181300 END;                                                                               
00181400                                                                                    
00181500 %***********************************************************************           
00181600 %                                                                                  
00181700 %  WRITE NEW TAPE FILE                                                             
00181800 %                                                                                  
00181900 %***********************************************************************           
00182000 PROCEDURE WRITENEXTNEWTAPE(LINEIMAGE,ENDOFINPUT);                                  
00182100 VALUE                                                                              
00182200   LINEIMAGE,ENDOFINPUT;                                                            
00182300 POINTER                                                                            
00182400   LINEIMAGE;                                                                       
00182500 BOOLEAN                                                                            
00182600   ENDOFINPUT;                                                                      
00182700 BEGIN                                                                              
00182800                                                                                    
00182900   IF NOT NEWTAPE.OPEN THEN BEGIN                                                   
00183000     NEWTAPE.MYUSE := VALUE(OUT);                                                   
00183100     NEWTAPE.OPEN := TRUE;                                                          
00183200     NEWTAPE.FILEKIND := VALUE(SEQDATA);                                            
00183300   END;                                                                             
00183400   IF ENDOFINPUT THEN BEGIN                                                         
00183500     CLOSE(NEWTAPE,CRUNCH);                                                         
00183600   END ELSE BEGIN                                                                   
00183700     WRITE(NEWTAPE,CARDSIZE,LINEIMAGE);                                             
00183800   END;                                                                             
00183900 END;                                                                               
00184000                                                                                    
00184100 %***********************************************************************           
00184200 %                                                                                  
00184300 %  ANALYSE $ CARDS                                                                 
00184400 %                                                                                  
00184500 %***********************************************************************           
00184600                                                                                    
00184700 PROCEDURE ANALYSEOPTION;                                                           
00184800 BEGIN                                                                              
00184900 INTEGER                                                                            
00185000          SCANCOUNT,          % USED TO COUNT CHARS LEFT IN SCAN                    
00185100          OPTMODE,            %MODE FLAG FOR SETTING OPTIONS                        
00185200          SAVEOPTMODE,        % SAVE IT                                             
00185300          OPTIONNO;           %COMPILER OPTION NUMBER                               
00185400 LABEL                                                                              
00185500          SKAN,                                                                     
00185600          ENDOFCARD;                                                                
00185700 POINTER                                                                            
00185800          P,                                                                        
00185900          PNEXTCHAR;          %NEXT CHARACTER                                       
00186000 TRUTHSET                                                                           
00186100          DIGITSYMBOLS("0123456789");                                               
00186200 TRANSLATETABLE LOWERTOUPPER(EBCDIC TO EBCDIC,                                      
00186300     "abcdefghijklmnopqrstuvwxyz" TO                                                
00186400     "ABCDEFGHIJKLMNOPQRSTUVWXYZ");                                                 
00186500 %***********************************************************************           
00186600 %                                                                                  
00186700 %  COMPILER OPTIONS                                                                
00186800 %                                                                                  
00186900 %***********************************************************************           
00187000                                                                                    
00187100 VALUE ARRAY COMPOPTIONS(              %STRUCTURE - WORD 1                          
00187200                                       %[47:8] - NO CHARACTERS IN OPTION            
00187300                                       %[39:8] - OPTION NUMBER                      
00187400                                       %[31:32] - OPTION NAME                       
00187500                                       %WORD 2 - OPTION NAME                        
00187600    4"0501"8"RESE","T     ",           %RESET         1                             
00187700    4"0302"8"SET ",                    %SET           2                             
00187800    4"0303"8"POP ",                    %POP           3                             
00187900    4"0812"8"LIST","INCL  ",           %LISTINCL     18                             
00188000    4"0404"8"LIST",                    %LIST          4                             
00188100    4"0305"8"NEW ",                    %NEW           5                             
00188200    4"0406"8"CODE",                    %CODE          6                             
00188300    4"0507"8"NAME","S     ",           %NAMES         7                             
00188400    4"0308"8"SEQ ",                    %SEQ           8                             
00188500    4"0409"8"OMIT",                    %OMIT          9                             
00188600    4"070A"8"ERRL","IST   ",           %ERRLIST      10                             
00188700    4"050B"8"CHEC","K     ",           %CHECK        11                             
00188800    4"010C"8"$   ",                    %$            12                             
00188900    4"070D"8"INCL","UDE   ",           %INCLUDE      13                             
00189000    4"070E"8"INCL","NEW   ",           %INCLNEW      14                             
00189100    4"050F"8"MERG","E     ",           %MERGE        15                             
00189200    4"0410"8"PAGE",                    %PAGE         16                             
00189300    4"0A11"8"ERRO","RLIMIT",           %ERRORLIMIT   17                             
00189400    4"0713"8"HEXC","ODE   ",           %HEXCODE      19                             
00189500    4"0814"8"LINE","INFO  ",           %LINEINFO     20                             
00189600    4"0517"8"ASCI"8"I     ",           %ASCII        23                             
00189700    4"0415"8"XREF",                    %XREF         21                             
00189800    4"0416"8"HEAP",                    %HEAP         22                             
00189900    4"0B18"8"TRUS"8"TWORTH"8"Y     ",  %TRUSTWORTHY  24                             
00190000    4"0819"8"STAN","DARD  ",           %STANDARD     25                             
00190100    4"081B"8"WARN","INGS  ",           %WARNINGS     27                             
00190200    4"0A1A"8"STAT","ISTICS",           %STATISTICS   26                             
00190300    4"0B1C"8"STRI","PBLANK","S     ",  %STRIPBLANKS  28                             
00190400    4"0B1D"8"BOUN","DSCHEC","K     ",  %BOUNDSCHECK  29                             
00190500    4"081E"8"BIND","INFO  ",           %BINDINFO     30                             
00190600    4"081F"8"AUTO","BIND  ",           %AUTOBIND     31                             
00190700    4"0420"8"BIND",                    %BIND         32                             
00190800    4"0621"8"BIND","ER    ",           %BINDER       33                             
00190900    4"0722"8"SETS","IZE   ",           %SETSIZE      34                             
00191000    0);                                                                             
00191100 DEFINE                                                                             
00191200   RESETOPTION = 1#,                                                                
00191300   SETOPTION = 2#,                                                                  
00191400   POPOPTION = 3#,                                                                  
00191500   LISTOPTION = 4#,                                                                 
00191600   NEWOPTION = 5#,                                                                  
00191700   CODEOPTION = 6#,                                                                 
00191800   NAMESOPTION = 7#,                                                                
00191900   SEQOPTION = 8#,                                                                  
00192000   OMITOPTION = 9#,                                                                 
00192100   ERRLISTOPTION = 10#,                                                             
00192200   CHECKOPTION = 11#,                                                               
00192300   DOLLAROPTION = 12#,                                                              
00192400   INCLUDEOPTION = 13#,                                                             
00192500   INCLNEWOPTION = 14#,                                                             
00192600   MERGEOPTION = 15#,                                                               
00192700   PAGEOPTION = 16#,                                                                
00192800   LIMITOPTION = 17#,                                                               
00192900   LISTINCLOPTION = 18#,                                                            
00193000   HEXCODEOPTION = 19#,                                                             
00193100   LINEINFOOPTION = 20#,                                                            
00193200   XREFOPTION = 21#,                                                                
00193300   HEAPOPTION = 22#,                                                                
00193400   ASCIIOPTION = 23#,                                                               
00193500   TRUSTWORTHYOPTION = 24#,                                                         
00193600   STANDARDOPTION = 25#,                                                            
00193700   STATISTICSOPTION = 26#,                                                          
00193800   WARNINGSOPTION = 27#,                                                            
00193900   STRIPBLANKSOPTION = 28#,                                                         
00194000   BOUNDSCHECKOPTION = 29#,                                                         
00194100   BINDINFOOPTION = 30#,                                                            
00194200   AUTOBINDOPTION = 31#,                                                            
00194300   BINDOPTION = 32#,                                                                
00194400   BINDEROPTION = 33#,                                                              
00194500   SETSIZEOPTION=34#;                                                               
00194600                                                                                    
00194700 DEFINE                                                                             
00194800   BUMPIT = PNEXTCHAR:=*+1#,                                                        
00194900   GETNEXTCHAR = SCAN PNEXTCHAR:PNEXTCHAR FOR                                       
00195000     SCANCOUNT:(72-DELTA(NEXTCHAR,PNEXTCHAR)) UNTIL EQL " ";                        
00195100     IF (SCANCOUNT=0) THEN GO TO ENDOFCARD;                                         
00195200     SCANIT#,                                                                       
00195300   SCANIT = SCAN PNEXTCHAR:PNEXTCHAR FOR                                            
00195400            SCANCOUNT:(72-DELTA(NEXTCHAR,PNEXTCHAR)) UNTIL NEQ " ";                 
00195500            IF (SCANCOUNT=0) THEN GO TO ENDOFCARD#,                                 
00195600   STOREOPTION(FLAG,ADDR) =                                                         
00195700     USEROPTIONS[ADDR]:=REAL(FLAG) #;                                               
00195800                                                                                    
00195900 PROCEDURE FINDUSEROPTION(A,B);                                                     
00196000 BOOLEAN A;                                                                         
00196100 INTEGER B;                                                                         
00196200 FORWARD;                                                                           
00196300                                                                                    
00196400 BOOLEAN PROCEDURE FINDOPTION(PTR);                                                 
00196500 POINTER                                                                            
00196600   PTR;                                                                             
00196700 BEGIN                                                                              
00196800   INTEGER                                                                          
00196900     I,                                                                             
00197000     CHARSIZE;                                                                      
00197100   TRUTHSET                                                                         
00197200     OPTIONDELS(" 0123456789,=");                                                   
00197300   POINTER                                                                          
00197400     PA;                                                                            
00197500   LABEL                                                                            
00197600     FOUND,                                                                         
00197700     EXIT;                                                                          
00197800   I:=0;                                                                            
00197900   SCAN PA:PTR FOR (72-DELTA(NEXTCHAR,PTR)) UNTIL IN OPTIONDELS;                    
00198000   DO BEGIN                                                                         
00198100     CHARSIZE:= COMPOPTIONS[I].[47:8];                                              
00198200     IF (CHARSIZE=DELTA(PTR,PA)) THEN BEGIN                                         
00198300       IF (POINTER(COMPOPTIONS[I])+2 = PTR FOR CHARSIZE) THEN                       
00198400         GO TO FOUND;                                                               
00198500     END;                                                                           
00198600     I:=I+1+((CHARSIZE+1) DIV 6);                                                   
00198700   END UNTIL (COMPOPTIONS[I].[47:8]=0);                                             
00198800   GO TO EXIT;                                                                      
00198900 FOUND:                                                                             
00199000   FINDOPTION:= TRUE;                                                               
00199100   PTR:= *+CHARSIZE;                                                                
00199200   OPTIONNO:= COMPOPTIONS[I].[39:8];                                                
00199300 EXIT:                                                                              
00199400 END;                                                                               
00199500                                                                                    
00199600 PROCEDURE FIXOPTION(OPTION);                                                       
00199700 BOOLEAN                                                                            
00199800   OPTION;                                                                          
00199900 BEGIN                                                                              
00200000   DEFINE                                                                           
00200100     INITIALIZEALL = 0#,                                                            
00200200     INITIALIZEONE = 1#,                                                            
00200300     RESET = 2#,                                                                    
00200400     SET = 3#,                                                                      
00200500     POP = 4#;                                                                      
00200600   BOOLEAN                                                                          
00200700     B,                                                                             
00200800     BOOL;                                                                          
00200900   INTEGER                                                                          
00201000     ADDR;                                                                          
00201100   CASE OPTMODE OF BEGIN                                                            
00201200   INITIALIZEALL:                                                                   
00201300     BEGIN                    %OPTMODE = 0 INITIALIZE ALL OPTIONS                   
00201400       CHECKTOG:= CODETOG:=                                                         
00201500       ERRLISTTOG:= INCLNEWTOG:=                                                    
00201600       DOLLARTOG:= LISTTOG:=                                                        
00201700       LISTINCLTOG:= MERGETOG:=                                                     
00201800       NEWTOG:= OMITTING:=                                                          
00201900       SEQTOG:= NAMESTOG:=                                                          
00202000       HEXCODETOG:= LINEINFOTOG:=                                                   
00202100       ASCIITOG:=XREFTOG:=                                                          
00202200       TRUSTWORTHYTOG:=STANDARDTOG:=STATISTICSTOG:=                                 
00202300       WARNINGSTOG:=                                                                
00202400       STRIPBLANKSTOG:=                                                             
00202500       BOUNDSCHECKTOG:=                                                             
00202600       BINDINFOTOG:=                                                                
00202700       AUTOBINDTOG:=                                                                
00202800         FALSE;                                                                     
00202900       OPTION:= TRUE;                                                               
00203000       OPTMODE:= 1;                                                                 
00203100     END;                                                                           
00203200   INITIALIZEONE:                                                                   
00203300     OPTION:= TRUE;           %OPTMODE = 1 ($ OPTION NAME)                          
00203400   RESET:                                                                           
00203500     OPTION:= FALSE & OPTION[46:45:46];   %OPTMODE = 2 (RESET)                      
00203600   SET:                                                                             
00203700     BEGIN                    %OPTMODE = 3 (SET)                                    
00203800       SCAN PNEXTCHAR:PNEXTCHAR FOR (71-DELTA(NEXTCHAR,PNEXTCHAR))                  
00203900         UNTIL NEQ " ";                                                             
00204000       IF (PNEXTCHAR = "=" FOR 1) THEN BEGIN                                        
00204100         BUMPIT;                                                                    
00204200         SCANIT;                                                                    
00204300         IF (B:=PNEXTCHAR = "NOT" FOR 3) THEN BEGIN                                 
00204400           GETNEXTCHAR;                                                             
00204500         END;                                                                       
00204600         FINDUSEROPTION(BOOL,ADDR);                                                 
00204700         B:= IF B THEN NOT BOOL ELSE BOOL;                                          
00204800       END ELSE B:=TRUE;                                                            
00204900       OPTION := B & OPTION[46:46];                                                 
00205000     END;                                                                           
00205100   POP:                                                                             
00205200     OPTION:= OPTION.[46:46]; %OPTMODE = 4 (POP)                                    
00205300   END CASES;                                                                       
00205400 END;                                                                               
00205500                                                                                    
00205600 PROCEDURE CONVERTTONO (NUMBER);                                                    
00205700 INTEGER                                                                            
00205800   NUMBER;                                                                          
00205900 BEGIN                                                                              
00206000   TRUTHSET DIGITS ("0123456789");                                                  
00206100   IF (PNEXTCHAR IN DIGITS) THEN BEGIN                                              
00206200     SCAN P:PNEXTCHAR FOR 8 WHILE IN DIGITS;                                        
00206300     NUMBER:= INTEGER(PNEXTCHAR,DELTA(PNEXTCHAR,P));                                
00206400     PNEXTCHAR:= P;                                                                 
00206500   END ELSE                                                                         
00206600     OPTERROR(PNEXTCHAR,1001);                                                      
00206700 END;                                                                               
00206800                                                                                    
00206900 PROCEDURE FINDUSEROPTION(WORD,ADDR);                                               
00207000 BOOLEAN                                                                            
00207100   WORD;                                                                            
00207200 INTEGER                                                                            
00207300   ADDR;                                                                            
00207400 BEGIN                                                                              
00207500   INTEGER                                                                          
00207600     I,                                                                             
00207700     NOCHARS;                                                                       
00207800   DEFINE                                                                           
00207900     NOCHARSMASK = [47:8]#,                                                         
00208000     INSERTENTRY = BEGIN                                                            
00208100       TRUTHSET DELIMS (" =,");                                                     
00208200       REPLACE POINTER(USEROPTIONS[I])+1 BY P:PNEXTCHAR UNTIL IN                    
00208300         DELIMS;                                                                    
00208400       NOCHARS:=DELTA(PNEXTCHAR,P);                                                 
00208500       USEROPTIONS[I]:=* & NOCHARS [47:7:8];                                        
00208600       ADDR:= I+1+(NOCHARS DIV 6);                                                  
00208700       WORD:=BOOLEAN(USEROPTIONS[ADDR]);                                            
00208800       PNEXTCHAR:=P;                                                                
00208900     END#;                                                                          
00209000   LABEL                                                                            
00209100     EXIT;                                                                          
00209200   I:=0;                                                                            
00209300   DO BEGIN                                                                         
00209400     NOCHARS:=USEROPTIONS[I].NOCHARSMASK;                                           
00209500     IF (NOCHARS = 0) THEN BEGIN                                                    
00209600       INSERTENTRY;                                                                 
00209700       GO TO EXIT;                                                                  
00209800     END;                                                                           
00209900     IF (PNEXTCHAR = POINTER(USEROPTIONS[I])+1 FOR NOCHARS) THEN BEGIN              
00210000       ADDR:= I:= I+1+(NOCHARS DIV 6);                                              
00210100       WORD:= BOOLEAN(USEROPTIONS[ADDR]);                                           
00210200       PNEXTCHAR:= *+NOCHARS;                                                       
00210300       GO TO EXIT;                                                                  
00210400     END;                                                                           
00210500     I:=*+2+(NOCHARS DIV 6);                                                        
00210600   END UNTIL (I>=USERARRAYSIZE);                                                    
00210700   OPTERROR(PNEXTCHAR,1002);                                                        
00210800 EXIT:                                                                              
00210900 END;                                                                               
00211000                                                                                    
00211100 PROCEDURE FINDFIRSTREC(FIRSTSEQ);                                                  
00211200 VALUE                                                                              
00211300   FIRSTSEQ;                                                                        
00211400 INTEGER                                                                            
00211500   FIRSTSEQ;                                                                        
00211600 BEGIN                                                                              
00211700   DEFINE                                                                           
00211800     SEQNO = POINTER(INCLBUFF[INCLX,0])+72#;                                        
00211900   INTEGER                                                                          
00212000     NUMBER;                                                                        
00212100   LABEL                                                                            
00212200     EXIT;                                                                          
00212300   VALIDINCLBUFF:= FALSE;                                                           
00212400   DO BEGIN                                                                         
00212500     READ(INCLFILE,CARDSIZE,INCLBUFF[INCLX,*]) [EXIT];                              
00212600     NUMBER:= INTEGER(SEQNO,8);                                                     
00212700   END UNTIL (NUMBER >= FIRSTSEQ);                                                  
00212800   VALIDINCLBUFF:= TRUE;                                                            
00212900 EXIT:                                                                              
00213000 END;                                                                               
00213100                                                                                    
00213200 PROCEDURE STARTINCLUDING;                                                          
00213300 BEGIN                                                                              
00213400   LABEL                                                                            
00213500     EXIT,                                                                          
00213600     NOOPTION,                                                                      
00213700     NEXTOPTION,                                                                    
00213800     ALREADYOPEN,                                                                   
00213900     CHECKOPTION,                                                                   
00214000     AWAY,                                                                          
00214100     SEARCHINCL;                                                                    
00214200   DEFINE                                                                           
00214300     PTEMP40 = POINTER(TEMP[40])#,                                                  
00214400     PTEMP0 = POINTER(TEMP[0])#;                                                    
00214500   INTEGER                                                                          
00214600     I,                                                                             
00214700     FIRSTSEQ;                                                                      
00214800   POINTER                                                                          
00214900     Q;                                                                             
00215000   ALPHA ARRAY                                                                      
00215100     TEMP[0:79];                                                                    
00215200   TRUTHSET                                                                         
00215300     DELS(".""""),                                                                  
00215400     DIGITS("0123456789"),                                                          
00215500     LETTERS(ALPHA AND NOT DIGITS);                                                 
00215600   IF (NEWTOG AND NOT INCLNEWTOG AND (INCLX<0)) THEN                                
00215700      WRITENEXTNEWTAPE(NEXTCHAR,FALSE);   % $INCLUDE TO NEWTAPE                     
00215800   IF (DOLLARTOG AND LISTTOG) THEN BEGIN                                            
00215900     EDITLINE(NEXTCHAR);                                                            
00216000     WRITELINE;                                                                     
00216100   END;                                                                             
00216200   SCANIT;                                                                          
00216300   FIRSTSEQ:=-1;                                                                    
00216400   STARTINCL:=TRUE;                                                                 
00216500   IF (INCLX GEQ INCLMAX) THEN BEGIN                                                
00216600     OPTERROR(PNEXTCHAR,1003);                                                      
00216700     GO TO EXIT;                                                                    
00216800   END;                                                                             
00216900   IF(INCLX<0) THEN SAVEINCLSEQ:=INCLSEQ                                            
00217000   ELSE BEGIN                                                                       
00217100       INCLDIR[I:=INCLX*INCLSZ]:= INCLSEQ;  %SAVE CURRENT STATE INCL TEXT           
00217200       INCLDIR[I+1]:= STOPINCLSEQ ;                                                 
00217300       INCLDIR[I+2]:= LASTINCLSEQ;                                                  
00217400   END;                                                                             
00217500   INCLX:=*+1;                                                                      
00217600   STOPINCLSEQ:= MAXINTEGER;                                                        
00217700   IF (LASTUSED NEQ 0) THEN BEGIN                                                   
00217800     SAVELASTUSED:= LASTUSED;                                                       
00217900     LASTUSED:=0;                                                                   
00218000   END;                                                                             
00218100   IF (PNEXTCHAR IN LETTERS) THEN BEGIN   %THIS IS INTNAME                          
00218200     REPLACE PTEMP0 BY P:PNEXTCHAR WHILE IN ALPHA,                                  
00218300       "." FOR 1;                                                                   
00218400     IF INCLFILE.OPEN THEN BEGIN                                                    
00218500       REPLACE PTEMP40 BY INCLFILE.INTNAME;                                         
00218600       IF (PTEMP0 = PTEMP40 FOR DELTA(PNEXTCHAR,P)) THEN BEGIN                      
00218700                              %HAVE CORRECT FILE                                    
00218800 ALREADYOPEN:                                                                       
00218900         INCLSEQ:= INCLDIR[I:=INCLX*INCLSZ];                                        
00219000         LASTINCLSEQ:= INCLDIR[I+2];                                                
00219100         VALIDINCLBUFF:=BOOLEAN(INCLDIR[I+1]).VALIDBIT;                             
00219200         GO TO NEXTOPTION;                                                          
00219300       END;                                                                         
00219400       CLOSE(INCLFILE);                                                             
00219500     END;                                                                           
00219600     REPLACE INCLFILE.TITLE BY POINTER(TEMP);                                       
00219700     REPLACE INCLFILE.INTNAME BY POINTER(TEMP);                                     
00219800     GO TO NEXTOPTION;                                                              
00219900   END;                                                                             
00220000   IF (PNEXTCHAR = """ FOR 1) THEN BEGIN   %THIS IS FILE TITLE                      
00220100     REPLACE Q:PTEMP0 BY P:PNEXTCHAR+1 UNTIL IN DELS;                               
00220200     REPLACE Q:Q BY "." FOR 1;                                                      
00220300     IF INCLFILE.OPEN THEN BEGIN                                                    
00220400       REPLACE PTEMP40 BY INCLFILE.TITLE;                                           
00220500       IF(PTEMP0 = "(" FOR 1) THEN Q:=PTEMP40                                       
00220600       ELSE BEGIN                                                                   
00220700         SCAN Q:PTEMP40 UNTIL EQL ")";                                              
00220800         Q:=*+1;                                                                    
00220900       END;                                                                         
00221000       IF (PTEMP0 = Q FOR DELTA(PNEXTCHAR,P)-1) THEN                                
00221100         GO TO ALREADYOPEN;                                                         
00221200       CLOSE(INCLFILE);                                                             
00221300     END;                                                                           
00221400     REPLACE INCLFILE.INTNAME BY "INCLUDE.";                                        
00221500     REPLACE INCLFILE.TITLE BY PTEMP0;                                              
00221600   END ELSE                   %NO FILE OPTION SPECIFIED                             
00221700     IF INCLFILE.OPEN THEN GO TO ALREADYOPEN                                        
00221800     ELSE BEGIN                                                                     
00221900       REPLACE INCLFILE.INTNAME BY "INCLUDE.";                                      
00222000       IF NOT INCLFILE.RESIDENT THEN OPTERROR(PNEXTCHAR,1004);                      
00222100       GO TO CHECKOPTION;                                                           
00222200   END;                                                                             
00222300 NEXTOPTION:                                                                        
00222400   SCAN PNEXTCHAR:PNEXTCHAR FOR (71-DELTA(NEXTCHAR,PNEXTCHAR)) UNTIL EQL            
00222500     " ";                                                                           
00222600 CHECKOPTION:                                                                       
00222700   SCAN PNEXTCHAR:PNEXTCHAR FOR                                                     
00222800     SCANCOUNT:(71-DELTA(NEXTCHAR,PNEXTCHAR)) UNTIL NEQ " ";                        
00222900   IF (SCANCOUNT=0) THEN GO TO NOOPTION;                                            
00223000   IF (PNEXTCHAR IN DIGITS) THEN BEGIN  %STARTING SEQUENCE NO.                      
00223100     CONVERTTONO(FIRSTSEQ);                                                         
00223200     SCANIT;                                                                        
00223300     GO TO CHECKOPTION;                                                             
00223400   END;                                                                             
00223500   IF  (PNEXTCHAR = "-" FOR 1) THEN                                                 
00223600   BEGIN                                                                            
00223700     BUMPIT;                                                                        
00223800     SCANIT;                                                                        
00223900     IF (PNEXTCHAR IN DIGITS) THEN   %STOPPING SEQUENCE NO.                         
00224000       CONVERTTONO(STOPINCLSEQ)                                                     
00224100     ELSE OPTERROR(PNEXTCHAR,1001);                                                 
00224200   END ELSE                                                                         
00224300     IF (PNEXTCHAR = "*" FOR 1) THEN BEGIN                                          
00224400       FIRSTSEQ:=-1;                                                                
00224500       BUMPIT;                                                                      
00224600       GO TO CHECKOPTION;                                                           
00224700     END ELSE IF (PNEXTCHAR NEQ "%" FOR 1) THEN                                     
00224800       OPTERROR(PNEXTCHAR,1005);                                                    
00224900 NOOPTION:                                                                          
00225000   NEXTCHAR:= PINCLBUFF0:= POINTER(INCLBUFF[INCLX,*]);                              
00225100   LASTCHAR:=PINCLBUFF73:= NEXTCHAR+72;                                             
00225200   IF INCLFILE.OPEN THEN BEGIN   %FILE ALREADY OPEN                                 
00225300     IF (FIRSTSEQ = -1) THEN GO AWAY;                                               
00225400     IF NOT VALIDINCLBUFF THEN                                                      
00225500       IF READINCLUDE THEN BEGIN                                                    
00225600         REWIND(INCLFILE);                                                          
00225700         GO TO SEARCHINCL;                                                          
00225800     END;                                                                           
00225900     IF ((FIRSTSEQ > LASTINCLSEQ) AND (FIRSTSEQ LEQ INCLSEQ)) THEN                  
00226000       GO AWAY;                                                                     
00226100     IF (FIRSTSEQ < INCLSEQ) THEN REWIND(INCLFILE);                                 
00226200     GO TO SEARCHINCL;                                                              
00226300   END ELSE BEGIN                                                                   
00226400     INCLFILE.FILETYPE:= 8;                                                         
00226500     INCLFILE.MAXRECSIZE:= CARDWORDSIZE;                                            
00226600     INCLFILE.OPEN:= TRUE;                                                          
00226700 SEARCHINCL:                                                                        
00226800     VALIDINCLBUFF:= FALSE;                                                         
00226900     INCLSEQ:= -1;                                                                  
00227000     IF (FIRSTSEQ < 0) THEN GO AWAY;                                                
00227100     VALIDINCLBUFF:= NOT READINCLUDE;                                               
00227200     IF ((FIRSTSEQ > LASTINCLSEQ) AND (FIRSTSEQ <= INCLSEQ)) THEN                   
00227300       GO AWAY;                                                                     
00227400     FINDFIRSTREC(FIRSTSEQ);                                                        
00227500   END;                                                                             
00227600 AWAY:                                                                              
00227700   REPLACE LASTSEQUENCE BY " " FOR 8;                                               
00227800   IF (LASTUSED NEQ 0) THEN BEGIN                                                   
00227900     SAVELASTUSED:= LASTUSED;                                                       
00228000     LASTUSED:=0;                                                                   
00228100   END;                                                                             
00228200 EXIT:                                                                              
00228300 END;                                                                               
00228400                                                                                    
00228500 PROCEDURE BINDDATA(BINDER);                                                        
00228600 %         ********                                                                 
00228700 VALUE BINDER;                                                                      
00228800 BOOLEAN BINDER;                                                                    
00228900 BEGIN                                                                              
00229000 BOOLEAN                                                                            
00229100   SPACEREQ;                                                                        
00229200 INTEGER                                                                            
00229300   IDLENGTH,K,                                                                      
00229400   CARDCHARS;                                                                       
00229500                                                                                    
00229600 SPACEREQ := FALSE;                                                                 
00229700 IF BINDER THEN BEGIN                                                               
00229800   REPLACE BINDCONTROL[CBINDCHARS] BY "$" FOR 1;                                    
00229900   CBINDCHARS:=*+1;                                                                 
00230000   CARDCHARS := *+1;                                                                
00230100 END ELSE BEGIN                                                                     
00230200   REPLACE BINDCONTROL[CBINDCHARS] BY "BIND " FOR 5;                                
00230300   CBINDCHARS:=*+5;                                                                 
00230400   CARDCHARS:=*+5;                                                                  
00230500 END;                                                                               
00230600 SCANCOUNT:=72 - DELTA(NEXTCHAR,PNEXTCHAR);                                         
00230700 SCAN PNEXTCHAR:PNEXTCHAR FOR SCANCOUNT:SCANCOUNT UNTIL NEQ " ";                    
00230800 WHILE SCANCOUNT > 0 DO BEGIN                                                       
00230900   IF (PNEXTCHAR IN ALPHA) THEN BEGIN                                               
00231000     SCAN PNEXTCHAR FOR K:SCANCOUNT WHILE IN ALPHA;                                 
00231100     IDLENGTH := SCANCOUNT - K;                                                     
00231200   END ELSE BEGIN                                                                   
00231300     IDLENGTH := 1;                                                                 
00231400   END;                                                                             
00231500   IF((IDLENGTH+CBINDCHARS+6) > MAXBINDCHARS) THEN BEGIN                            
00231600     ERROR(2021);                                                                   
00231700   END ELSE BEGIN                                                                   
00231800     IF (PNEXTCHAR IN ALPHA) THEN BEGIN                                             
00231900       IF SPACEREQ THEN BEGIN                                                       
00232000         REPLACE BINDCONTROL[CBINDCHARS] BY " ";                                    
00232100         CBINDCHARS:=*+1;                                                           
00232200       END;                                                                         
00232300       SPACEREQ:=TRUE;                                                              
00232400     END ELSE BEGIN                                                                 
00232500       SPACEREQ:=FALSE;                                                             
00232600     END;                                                                           
00232700     REPLACE BINDCONTROL[CBINDCHARS] BY PNEXTCHAR FOR IDLENGTH;                     
00232800     CBINDCHARS:=*+IDLENGTH;                                                        
00232900     PNEXTCHAR := *+IDLENGTH;                                                       
00233000     SCANCOUNT := SCANCOUNT-IDLENGTH;                                               
00233100   END;                                                                             
00233200   SCAN PNEXTCHAR:PNEXTCHAR FOR SCANCOUNT:SCANCOUNT UNTIL NEQ " ";                  
00233300 END;                                                                               
00233400 REPLACE BINDCONTROL[CBINDCHARS] BY ";" FOR 1;                                      
00233500 CBINDCHARS:=*+1;                                                                   
00233600 END;   %OF BINDDATA                                                                
00233700                                                                                    
00233800 PROCEDURE INITBINDCONTROL;                                                         
00233900 %         ***************                                                          
00234000 BEGIN                                                                              
00234100 POINTER P,OLDP;                                                                    
00234200 INTEGER I;                                                                         
00234300 I:=0;                                                                              
00234400 REPLACE BINDCONTROL[0] BY "CBIND = FROM ", CODE.TITLE;                             
00234500 P:=BINDCONTROL[13];                                                                
00234600 DO BEGIN                                                                           
00234700   IF P=""" THEN BEGIN                                                              
00234800     SCAN P:P UNTIL = """;                                                          
00234900     P:=P+1;                                                                        
00235000   END ELSE BEGIN                                                                   
00235100     SCAN P:P FOR 17 UNTIL = "/";                                                   
00235200   END;                                                                             
00235300   OLDP:=P;                                                                         
00235400   IF P="/" THEN BEGIN                                                              
00235500     I:=I+1;                                                                        
00235600   END;                                                                             
00235700   P:=*+1;                                                                          
00235800 END UNTIL (P NEQ "/");                                                             
00235900 IF (I>0) THEN BEGIN                                                                
00236000   REPLACE OLDP:OLDP BY "/=;";                                                      
00236100 END ELSE BEGIN                                                                     
00236200   REPLACE OLDP:BINDCONTROL[0] BY "BIND = FROM OBJECT/=;";                          
00236300 END;                                                                               
00236400 CBINDCHARS:=DELTA(BINDCONTROL,OLDP);                                               
00236500 END;   %OF INITBINDCONTROL                                                         
00236600                                                                                    
00236700                                                                                    
00236800 %***********************************************************************           
00236900 %                                                                                  
00237000 %  ANALYSE COMPILER OPTIONS (MAIN SECTION)                                         
00237100 %                                                                                  
00237200 %***********************************************************************           
00237300                                                                                    
00237400 REPLACE NEXTCHAR BY NEXTCHAR FOR 72 WITH LOWERTOUPPER;                             
00237500 PNEXTCHAR:=NEXTCHAR+(IF(NEXTCHAR = "$" FOR 1) THEN 1                               
00237600                ELSE 2);                                                            
00237700 SKAN:                                                                              
00237800 SCANIT;                                                                            
00237900 IF (PNEXTCHAR = "," FOR 1) THEN BEGIN                                              
00238000   BUMPIT;                                                                          
00238100   GO TO SKAN;                                                                      
00238200 END;                                                                               
00238300 IF FINDOPTION(PNEXTCHAR) THEN BEGIN                                                
00238400     CASE OPTIONNO OF BEGIN                                                         
00238500     RESETOPTION: SETOPTION: POPOPTION: %RESET,SET,POP                              
00238600       BEGIN                                                                        
00238700         OPTMODE:= OPTIONNO+1;                                                      
00238800         GO TO SKAN;                                                                
00238900       END;                                                                         
00239000     LISTOPTION:                                                                    
00239100       FIXOPTION(LISTTOG);              %LIST                                       
00239200     NEWOPTION:                                                                     
00239300       FIXOPTION(NEWTOG);               %NEW                                        
00239400     CODEOPTION:                                                                    
00239500       FIXOPTION(CODETOG);              %CODE                                       
00239600     NAMESOPTION:                                                                   
00239700       FIXOPTION(NAMESTOG);             %NAMES                                      
00239800     SEQOPTION:                                                                     
00239900       BEGIN                            %SEQ                                        
00240000         FIXOPTION(SEQTOG);                                                         
00240100         SCANIT;                                                                    
00240200         IF (PNEXTCHAR IN DIGITSYMBOLS) THEN CONVERTTONO(RESEQNO);                  
00240300         SCANIT;                                                                    
00240400         IF(PNEXTCHAR = "+" FOR 1) THEN BEGIN                                       
00240500           BUMPIT;                                                                  
00240600           SCANIT;                                                                  
00240700           CONVERTTONO(RESEQINC);                                                   
00240800         END;                                                                       
00240900       END;                                                                         
00241000     OMITOPTION:                                                                    
00241100       FIXOPTION(OMITTING);             %OMIT                                       
00241200     ERRLISTOPTION:                                                                 
00241300       FIXOPTION(ERRLISTTOG);           %ERRLIST                                    
00241400     CHECKOPTION:                                                                   
00241500       FIXOPTION(CHECKTOG);             %CHECK                                      
00241600     DOLLAROPTION:                                                                  
00241700       FIXOPTION(DOLLARTOG);            %$                                          
00241800     INCLUDEOPTION:                                                                 
00241900       BEGIN                            %INCLUDE                                    
00242000         IF NOT OMITTING THEN                                                       
00242100           STARTINCLUDING;                                                          
00242200       END;                                                                         
00242300     INCLNEWOPTION:                                                                 
00242400       FIXOPTION(INCLNEWTOG);           %INCLNEW                                    
00242500     MERGEOPTION:                                                                   
00242600       BEGIN                            %MERGE                                      
00242700         FIXOPTION(MERGETOG);                                                       
00242800         IF MERGETOG THEN BEGIN                                                     
00242900           IF NOT TAPERES THEN BEGIN                                                
00243000             TAPE.MAXRECSIZE:= CARDWORDSIZE;                                        
00243100             TAPE.OPEN:=TAPERES:= TRUE;                                             
00243200           END;                                                                     
00243300           IF (LASTUSED = 1) THEN LASTUSED:=3;                                      
00243400         END ELSE                                                                   
00243500           LASTUSED:= 1;                                                            
00243600       END;                                                                         
00243700     PAGEOPTION:                                                                    
00243800       IF LISTTOG THEN                  %PAGE                                       
00243900         WRITE(LINE[SKIP 1]);                                                       
00244000     LIMITOPTION:                                                                   
00244100       BEGIN                            %LIMIT                                      
00244200         SCANIT;                                                                    
00244300         IF (PNEXTCHAR = "=") THEN BEGIN                                            
00244400           PNEXTCHAR := *+1;                                                        
00244500           SCANIT;                                                                  
00244600         END;                                                                       
00244700         CONVERTTONO(ERRORCOUNT);                                                   
00244800         CHECKERRORLIMIT;                                                           
00244900       END;                                                                         
00245000     LISTINCLOPTION:                                                                
00245100       FIXOPTION(LISTINCLTOG);          %LISTINCL                                   
00245200     HEXCODEOPTION:                                                                 
00245300       FIXOPTION(HEXCODETOG);           %HEXCODE                                    
00245400     LINEINFOOPTION:                    %LINEINFO                                   
00245500       FIXOPTION(LINEINFOTOG);                                                      
00245600     XREFOPTION:                        %XREF                                       
00245700       FIXOPTION(XREFTOG);                                                          
00245800     HEAPOPTION:                        %HEAP                                       
00245900       BEGIN                                                                        
00246000         SCANIT;                                                                    
00246100         IF (PNEXTCHAR = "=") THEN BEGIN                                            
00246200           PNEXTCHAR := *+1;                                                        
00246300           SCANIT;                                                                  
00246400         END;                                                                       
00246500         CONVERTTONO(HEAPSIZE);                                                     
00246600       END;                                                                         
00246700     ASCIIOPTION:                       %ASCII                                      
00246800       FIXOPTION(ASCIITOG);                                                         
00246900     TRUSTWORTHYOPTION:                 %TRUSTWORTHY                                
00247000       FIXOPTION(TRUSTWORTHYTOG);                                                   
00247100     STANDARDOPTION:                    %STANDARD                                   
00247200       FIXOPTION(STANDARDTOG);                                                      
00247300       IF STANDARDTOG THEN BEGIN                                                    
00247400         SAVEOPTMODE := OPTMODE;                                                    
00247500         OPTMODE := 3;                                                              
00247600         FIXOPTION(WARNINGSTOG);                                                    
00247700         OPTMODE := SAVEOPTMODE;                                                    
00247800       END;                                                                         
00247900     STATISTICSOPTION:                  %STATISTICS                                 
00248000       FIXOPTION(STATISTICSTOG);                                                    
00248100     WARNINGSOPTION:                    %WARNINGS                                   
00248200       FIXOPTION(WARNINGSTOG);                                                      
00248300     STRIPBLANKSOPTION:                 %STRIPBLANKS                                
00248400       FIXOPTION(STRIPBLANKSTOG);                                                   
00248500     BOUNDSCHECKOPTION:                 %BOUNDSCHECK                                
00248600       FIXOPTION(BOUNDSCHECKTOG);                                                   
00248700     BINDINFOOPTION:                    %BINDINFO                                   
00248800       FIXOPTION(BINDINFOTOG);                                                      
00248900     AUTOBINDOPTION:                    %AUTOBIND                                   
00249000       FIXOPTION(AUTOBINDTOG);                                                      
00249100       IF AUTOBINDTOG THEN BEGIN                                                    
00249200         REPLACE BINDCONTROL[0] BY " " FOR MAXBINDCHARS;                            
00249300         INITBINDCONTROL;                                                           
00249400         BINDINFOTOG:=TRUE;                                                         
00249500       END;                                                                         
00249600     BINDOPTION:                        %BIND                                       
00249700       BINDDATA(FALSE);                                                             
00249800     BINDEROPTION:                      %BINDER                                     
00249900       BINDDATA(TRUE);                                                              
00250000     SETSIZEOPTION:                     %SETSIZE                                    
00250100       BEGIN                                                                        
00250200         SCANIT;                                                                    
00250300         IF (PNEXTCHAR="=") THEN BEGIN                                              
00250400           PNEXTCHAR := *+1;                                                        
00250500           SCANIT;                                                                  
00250600         END;                                                                       
00250700         CONVERTTONO(MAXSETSIZE);                                                   
00250800         MAXSETSIZE:=*-1;                                                           
00250900         MAXSETSIZE := MIN (MAXSETSIZE,65536);                                      
00251000       END;                                                                         
00251100     END OF CASE STATEMENT;                                                         
00251200 END ELSE BEGIN                                                                     
00251300   BOOLEAN                                                                          
00251400     FLAG;                                                                          
00251500   INTEGER                                                                          
00251600     ADDR;                                                                          
00251700   IF (PNEXTCHAR < "A" OR PNEXTCHAR > "Z") THEN BEGIN                               
00251800     OPTERROR(PNEXTCHAR,1006);                                                      
00251900     GETNEXTCHAR;                                                                   
00252000     GO TO SKAN;                                                                    
00252100   END;                                                                             
00252200   FINDUSEROPTION(FLAG,ADDR);                                                       
00252300   FIXOPTION(FLAG);                                                                 
00252400   STOREOPTION(FLAG,ADDR);                                                          
00252500 END;                                                                               
00252600 GO TO SKAN;                                                                        
00252700 ENDOFCARD:                                                                         
00252800 IF (NEXTCHAR = " $" FOR 2) THEN BEGIN                                              
00252900   IF SEQTOG THEN BEGIN                                                             
00253000     REPLACE NEXTCHAR+72 BY RESEQNO FOR 8 DIGITS;                                   
00253100     RESEQNO := *+RESEQINC;                                                         
00253200   END;                                                                             
00253300   IF NEWTOG THEN BEGIN                                                             
00253400     WRITENEXTNEWTAPE(NEXTCHAR,FALSE);                                              
00253500   END;                                                                             
00253600 END;                                                                               
00253700 END OF ANALYSEOPTION;                                                              
00253800                                                                                    
00253900 %***********************************************************************           
00254000 %                                                                                  
00254100 %  PROCEDURES OF GENERAL USE                                                       
00254200 %                                                                                  
00254300 %***********************************************************************           
00254400                                                                                    
00254500                                                                                    
00254600 PROCEDURE EDITLINE(FIRSTCHAR);                                                     
00254700 VALUE FIRSTCHAR;                                                                   
00254800 POINTER FIRSTCHAR;                                                                 
00254900 BEGIN                                                                              
00255000   POINTER P,Q;                                                                     
00255100   REPLACE P:PLINEBUFF BY " " FOR 16,                                               
00255200       Q:FIRSTCHAR FOR 72,                                                          
00255300       " " FOR 8,                                                                   
00255400       Q FOR 8;                                                                     
00255500   IF OMITTING THEN                                                                 
00255600     REPLACE P:P BY "     OMIT "                                                    
00255700   ELSE BEGIN                                                                       
00255800     REPLACE H[0] BY SEGNUMBER.[11:48] FOR 3,                                       
00255900       (SEGWORDINDEX-SEGMENTBASE).[15:48] FOR 4,                                    
00256000       SEGSYLINDEX.[3:48] FOR 1;                                                    
00256100     REPLACE P:P BY "  ",                                                           
00256200       H[0] FOR 3 WITH HEXTOEBCDIC,                                                 
00256300       ":",                                                                         
00256400       H[3] FOR 4 WITH HEXTOEBCDIC,                                                 
00256500       ":",                                                                         
00256600       H[7] FOR 1 WITH HEXTOEBCDIC;                                                 
00256700   END;                                                                             
00256800   IF (INCLX >=0) THEN REPLACE PLINEBUFF+94 BY (INCLX+1) FOR 1 DIGITS;              
00256900 END;                                                                               
00257000                                                                                    
00257100 BOOLEAN PROCEDURE READINCLUDE;                                                     
00257200 BEGIN                                                                              
00257300   LABEL                                                                            
00257400     EXIT,EOFINCLUDE;                                                               
00257500   READ(INCLFILE,CARDSIZE,INCLBUFF[INCLX,*]) [EOFINCLUDE];                          
00257600   LASTINCLSEQ:=INCLSEQ;                                                            
00257700   INCLSEQ:=INTEGER(LASTCHAR,8);                                                    
00257800   VALIDINCLBUFF:=TRUE;                                                             
00257900   GO TO EXIT;                                                                      
00258000 EOFINCLUDE:                                                                        
00258100   INCLSEQ:=MAXINTEGER;                                                             
00258200   READINCLUDE:=TRUE;                                                               
00258300 EXIT:                                                                              
00258400 END;                                                                               
00258500                                                                                    
00258600 PROCEDURE WRITELINE;                                                               
00258700 BEGIN                                                                              
00258800   IF LISTTOG OR NOT ERRLISTTOG THEN BEGIN                                          
00258900     IF (NOT HEADINGPRINTED) THEN BEGIN                                             
00259000       HEADING;                                                                     
00259100     END;                                                                           
00259200     LINECOUNT:=*+1;                                                                
00259300     WRITE(LINE,22,LINEBUFF[*]);                                                    
00259400   END;                                                                             
00259500   REPLACE PLINEBUFF BY " " FOR 22 WORDS;                                           
00259600 END WRITELINE;                                                                     
00259700                                                                                    
00259800 PROCEDURE OPTERROR(PTR,NO);                                                        
00259900 VALUE                                                                              
00260000   PTR,                                                                             
00260100   NO;                                                                              
00260200 INTEGER                                                                            
00260300   NO;                                                                              
00260400 POINTER                                                                            
00260500   PTR;                                                                             
00260600 BEGIN                                                                              
00260700   DEFINE                                                                           
00260800     TOTALERRORS=6#,                                                                
00260900     ERR = ((NO DIV 1000)=1) #;                                                     
00261000   INTEGER                                                                          
00261100     I;                                                                             
00261200   BOOLEAN                                                                          
00261300     FOUND;                                                                         
00261400   VALUE ARRAY ERRORMSG(                                                            
00261500     "INVALID INTEGER                                             ",                
00261600     "COMPILER ERROR - TOO MANY USER OPTIONS                      ",                
00261700     "NESTING LEVEL OF $INCLUDE GREATER THAN ALLOWED MAXIMUM      ",                
00261800     "INCLUDE FILE NOT PRESENT ON DISK                            ",                
00261900     "INVALID CHARACTER IN $INCLUDE CARD                          ",                
00262000     "FIRST CHARACTER OF IDENTIFIER MUST BE A LETTER              "                 
00262100     );                                                                             
00262200   VALUE ARRAY ERRORNOS(                                                            
00262300     1001,                                                                          
00262400     1002,                                                                          
00262500     1003,                                                                          
00262600     1004,                                                                          
00262700     1005,                                                                          
00262800     1006                                                                           
00262900     );                                                                             
00263000   MYSELF.TASKVALUE:= 1;                                                            
00263100   I:=0;                                                                            
00263200   WHILE(I<= TOTALERRORS-1 AND NOT FOUND) DO BEGIN                                  
00263300     IF (ERRORNOS[I] = NO) THEN FOUND:= TRUE                                        
00263400     ELSE I:=*+1;                                                                   
00263500   END;                                                                             
00263600   IF FOUND THEN BEGIN                                                              
00263700     IF ERR THEN BEGIN                                                              
00263800       NOOFERRORS:=*+1;                                                             
00263900       REPLACE PLINEBUFF BY ">" FOR 6,                                              
00264000         NOOFERRORS FOR 4 DIGITS,                                                   
00264100         ">" FOR 6;                                                                 
00264200     END ELSE                                                                       
00264300       REPLACE PLINEBUFF BY                                                         
00264400         "W A R N I N G " FOR 14,                                                   
00264500         ">" FOR 2;                                                                 
00264600     IF ERRLISTTOG THEN BEGIN                                                       
00264700       REPLACE PERRORBUFF BY " " FOR 12 WORDS;                                      
00264800       REPLACE PERRORBUFF BY LASTSEQUENCE FOR 8,                                    
00264900         " ERROR-", POINTER(ERRORMSG[I*10]) FOR 60;                                 
00265000       WRITE(ERRORFILE,12,ERRORBUFF[*]);                                            
00265100     END;                                                                           
00265200     REPLACE PLINEBUFF+16 BY POINTER(ERRORMSG[I*10]) FOR 60;                        
00265300     WRITELINE;                                                                     
00265400     REPLACE PLINEBUFF+(16+ DELTA(LASTCHAR-72,PTR)) BY "*";                         
00265500     WRITELINE;                                                                     
00265600     CHECKERRORLIMIT;                                                               
00265700   END ELSE BEGIN                                                                   
00265800     REPLACE PLINEBUFF+16 BY " COMPILER ERROR MESSAGE ",                            
00265900       NO FOR 4 DIGITS;                                                             
00266000     WRITELINE;                                                                     
00266100     CHECKERRORLIMIT;                                                               
00266200   END;                                                                             
00266300 END;                                                                               
00266400                                                                                    
00266500 PROCEDURE HEADING;                                                                 
00266600 BEGIN                                                                              
00266700                                                                                    
00266800   INTEGER                                                                          
00266900     YEAR,MONTH,MDAY,HOUR,MINUTE,                                                   
00267000     YEARDAY,WEEKDAY,ADJHOUR,DAYSINMONTH,J,                                         
00267100     TIME0,TIME1;                                                                   
00267200                                                                                    
00267300   EBCDIC ARRAY LBUF[0:131];                                                        
00267400                                                                                    
00267500   POINTER P;                                                                       
00267600                                                                                    
00267700   EBCDIC VALUE ARRAY NAME(                                                         
00267800                                                                                    
00267900     "   MON","  TUES","WEDNES"," THURS",                                           
00268000     "   FRI"," SATUR","   SUN",                                                    
00268100                                                                                    
00268200     "JANUARY     ", "FEBRUARY    ",                                                
00268300     "MARCH       ", "APRIL       ",                                                
00268400     "MAY         ", "JUNE        ",                                                
00268500     "JULY        ", "AUGUST      ",                                                
00268600     "SEPTEMBER   ", "OCTOBER     ",                                                
00268700     "NOVEMBER    ", "DECEMBER    ",                                                
00268800                                                                                    
00268900     "B6700 PASCAL COMPILER"                                                        
00269000     );                                                                             
00269100                                                                                    
00269200   DEFINE NOOFCHARSINTITLE=21#;                                                     
00269300   % DO NOT FORGET TO ALTER THIS DEFINE WHEN CHANGING TITLE                         
00269400                                                                                    
00269500   LABEL  ESCAPE;                                                                   
00269600   J:=(132-(58+NOOFCHARSINTITLE)) DIV 2;                                            
00269700   TIME1:=TIME(1);                                                                  
00269800   TIME0:=TIME(0);                                                                  
00269900   YEARDAY:=((TIME0.[17:6]*10)+TIME0.[11:6])*10+TIME0.[5:6];                        
00270000   YEAR:=(TIME0.[29:6]*10)+TIME0.[23:6];                                            
00270100   MDAY:=YEARDAY;                                                                   
00270200   MONTH:=0;                                                                        
00270300   FOR DAYSINMONTH:=                                                                
00270400       31,                                                                          
00270500       (IF ((YEAR MOD 4) = 0) THEN 29 ELSE 28),                                     
00270600       31,30,31,30,31,31,30,31,30,31                                                
00270700       DO BEGIN                                                                     
00270800     IF (MDAY <= DAYSINMONTH) THEN GO TO ESCAPE;                                    
00270900     MDAY:=MDAY-DAYSINMONTH;                                                        
00271000     MONTH:=MONTH+1;                                                                
00271100   END;                                                                             
00271200 ESCAPE:                                                                            
00271300   WEEKDAY:=(((YEAR-1) DIV 4) + YEAR + YEARDAY + 6) MOD 7;                          
00271400   HOUR:=TIME1 DIV 216000;                                                          
00271500   MINUTE:=(TIME1 DIV 3600) MOD 60;                                                 
00271600   ADJHOUR:=HOUR MOD 12;                                                            
00271700   IF (ADJHOUR = 0) THEN ADJHOUR:=12;                                               
00271800   REPLACE LBUF[0] BY "      " FOR 22 WORDS;                                        
00271900   REPLACE P:LBUF[J] BY                                                             
00272000     NAME[186] FOR NOOFCHARSINTITLE,                                                
00272100     "   VERSION ",                                                                 
00272200     COMPILETIME(20) DIV 10 FOR 1 DIGITS, ".",                                      
00272300     COMPILETIME(20) MOD 10 FOR 1 DIGITS, ".",                                      
00272400     COMPILETIME(21) FOR 3 DIGITS, "   ",                                           
00272500     NAME[WEEKDAY*6] FOR 6,                                                         
00272600     "DAY,", " 19",                                                                 
00272700     YEAR FOR 2 DIGITS, " ",                                                        
00272800     NAME[MONTH*12+42] UNTIL = " ", " ",                                            
00272900     MDAY FOR DIGITSIN(MDAY) DIGITS, ", ",                                          
00273000     ADJHOUR FOR 2 DIGITS, ":",                                                     
00273100     MINUTE FOR 2 DIGITS, " ";                                                      
00273200   IF (HOUR >= 12) THEN                                                             
00273300     REPLACE P:P BY "PM."                                                           
00273400   ELSE                                                                             
00273500     REPLACE P:P BY "AM.";                                                          
00273600   WRITE(LINE,132,LBUF[*]);                                                         
00273700   REPLACE LBUF[J] BY "=" FOR DELTA(LBUF[J],P);                                     
00273800   WRITE(LINE,132,LBUF[*]);                                                         
00273900   WRITE(LINE [SPACE 2]);                                                           
00274000   REPLACE LBUF[0] BY " " FOR 132;                                                  
00274100   REPLACE LBUF[45] BY                                                              
00274200     "CARD FILE :- ",                                                               
00274300     CARD.TITLE;                                                                    
00274400   WRITE(LINE[SPACE 2],132,LBUF[*]);                                                
00274500   HEADINGPRINTED := TRUE;                                                          
00274600 END; % OF HEADING                                                                  
00274700 %***********************************************************************           
00274800 %***********************************************************************           
00274900 %**                                                                   **           
00275000 %**     (C) COPYRIGHT 1976  A.H.J.SALE AND R.A.FREAK                  **           
00275100 %**             HOBART, TASMANIA                                      **           
00275200 %**                                                                   **           
00275300 %**     NOT TO BE REPRODUCED IN WHOLE OR IN PART                      **           
00275400 %**     WITHOUT WRITTEN PERMISSION FROM THE AUTHORS:                  **           
00275500 %**             C/0 DEPARTMENT OF INFORMATION SCIENCE                 **           
00275600 %**             UNIVERSITY OF TASMANIA                                **           
00275700 %**             BOX 252C, G.P.O., HOBART                              **           
00275800 %**             TASMANIA  7001                                        **           
00275900 %**                                                                   **           
00276000 %**     ALL RIGHTS RESERVED                                           **           
00276100 %**                                                                   **           
00276200 %**     PACKAGE3                                                      **           
00276300 %**     --------                                                      **           
00276400 %**     IMPLEMENTS A SET OF ROUTINES THAT INCORPORATE LINE-INFO       **           
00276500 %**     DATA INTO THE CODE-FILE IN THE FORMAT EXPECTED BY THE         **           
00276600 %**     B6700 MCP.  THIS ENABLES THE LINEINFO OPTION TO BE            **           
00276700 %**     BUILT INTO COMPILERS, SO THAT THE STACK HISTORY CAN           **           
00276800 %**     INCLUDE THE LINE-NUMBER WHERE A RUN-TIME ERROR OCCURS.        **           
00276900 %**                                                                   **           
00277000 %**     NOT INTENDED TO BE USER MODIFIABLE                            **           
00277100 %**                                                                   **           
00277200 %***********************************************************************           
00277300 %***********************************************************************           
00277400 %***********************************************************************           
00277500 %                                                                                  
00277600 % COMPILER PACKAGE 2 VERSION 1.0  -CODE GENERATION-                                
00277700 %                                                                                  
00277800 % UTILITY ROUTINES                                                                 
00277900 %                                                                                  
00278000 % (C) COPYRIGHT  PROF A.H.J.SALE                                                   
00278100 %                DEPARTMENT OF INFORMATION SCIENCE                                 
00278200 %                UNIVERSITY OF TASMANIA                                            
00278300 %                BOX 252C G.P.O.  HOBART  TASMANIA 7001                            
00278400 %                                                                                  
00278500 % NOT USER-INTERFACE ROUTINES (HIDDEN)                                             
00278600 %   WILL NOT NEED USER-MODIFICATION                                                
00278700 %                                                                                  
00278800 %***********************************************************************           
00278900                                                                                    
00279000 DEFINE WRITETOLINE =                                                               
00279100   BEGIN                                                                            
00279200     IF (NOT HEADINGPRINTED) THEN HEADING;                                          
00279300     WRITE(LINE,22,LBUF[*]);                                                        
00279400     REPLACE LBUF0 BY " " FOR 22 WORDS;                                             
00279500   END;#;                                                                           
00279600                                                                                    
00279700                                                                                    
00279800 PROCEDURE PACKAGEERROR(ERRCODE,WHATLINE);                                          
00279900 %         ************                                                             
00280000 VALUE ERRCODE,WHATLINE;                                                            
00280100 INTEGER ERRCODE,WHATLINE;                                                          
00280200 %-----------------------------------------------------------------------           
00280300 %                                                                                  
00280400 % CALLED IF AN INVALID CALL IS DETECTED IN PACKAGE 2                               
00280500 %                                                                                  
00280600 %-----------------------------------------------------------------------           
00280700 BEGIN                                                                              
00280800   EBCDIC ARRAY EBUF[0:131];                                                        
00280900                                                                                    
00281000   EBCDIC VALUE ARRAY EMESSAGE(                                                     
00281100   % "123456789012345678901234567890123456789012345678901234567890", %*             
00281200     "????? (UNKNOWN): ERROR CODE OUT OF RANGE                    ", %0             
00281300     "GENWORD: CODE POINTER IS NOT AT A WORD BOUNDARY             ", %1             
00281400     "GENV: LEXICAL LEVEL IS GREATER THAN CURRENT LEVEL           ", %2             
00281500     "GENV: DISPLACEMENT TOO LARGE FOR ADDRESS-COUPLE FIELD       ", %3             
00281600     "GENEDIT: OP-CODE NOT IN EDIT RANGE (#D0 TO #DE)             ", %4             
00281700     "GENEDIT: REPEAT COUNT NOT PERMITTED IN THIS CONTEXT         ", %5             
00281800     "GENEDIT: CHAR PARAMETER WHICH IS NOT PERMITTED BY OP-CODE   ", %6             
00281900     "GENLT48: OPCODE IS NEITHER LT48 NOR MPCW                    ", %7             
00282000     "GENLT16: VALUE TAKES MORE THAN 16 BITS                      ", %8             
00282100     "GENOP2: OP-CODE IS NOT ISOL NOR INSR                        ", %9             
00282200     "GENOP1/OP2/FLTR: SYLLABLE PARAMETER IS TOO BIG FOR 8 BITS   ", %10            
00282300     "LABEL ROUTINES: LABEL PARAMETER -VE OR NOT ALLOCATED        ", %11            
00282400     "GENHALFWORDADDRESS: LABEL IS NOT AT A HALFWORD BOUNDARY     ", %12            
00282500     "GENLABEL: LABEL IS NOT AT A HALFWORD BOUNDARY               ", %13            
00282600     "GENLABEL: LABEL IS ALREADY SITED ELSEWHERE                  ", %14            
00282700     "MAKELABEL: THE LABELTABLE IS FULL: DISASTER FOLLOWS         ", %15            
00282800     "MAKED1SLOT: NO MORE ROOM IN SEGMENT DICTIONARY              ", %16            
00282900     "GENVARIANT: OP-CODE NOT VALID IN VARIANT MODE               ", %17            
00283000     "CLOSECODEFILE: SOME SEGMENTS HAVE NOT BEEN CLOSED/WRITTEN   ", %18            
00283100     "FILLER");                                                                     
00283200   DEFINE ERRLIMIT=18#;                                                             
00283300                                                                                    
00283400   INTEGER J;                                                                       
00283500                                                                                    
00283600   NOOFERRORS:=NOOFERRORS+1;                                                        
00283700   J:=ERRCODE;                                                                      
00283800   IF (J <= 0) OR (J > ERRLIMIT) THEN J:=0;                                         
00283900   IF LISTTOG THEN BEGIN                                                            
00284000     REPLACE EBUF[0] BY "      " FOR 22 WORDS;                                      
00284100     REPLACE EBUF[0] BY "=>=>=>=>COMPILER FAULT DETECTED AT LINE ",                 
00284200                        WHATLINE FOR 8 DIGITS,                                      
00284300                        " IN ROUTINE ",                                             
00284400                        EMESSAGE[J*60] FOR 60;                                      
00284500     WRITE(LINE,22,EBUF[*]);                                                        
00284600   END;                                                                             
00284700   IF ERRLISTTOG THEN BEGIN                                                         
00284800     REPLACE EBUF[0] BY "ERROR:", EMESSAGE[J*60] FOR 60;                            
00284900     WRITE(ERRORFILE,11,EBUF[*]);                                                   
00285000   END;                                                                             
00285100 END; % OF PACKAGE ERROR                                                            
00285200                                                                                    
00285300                                                                                    
00285400  $SET OMIT = NOT DEBUG                                                             
00285500 REAL PROCEDURE DIGITS4(LAB);                                                       
00285600 %              *******                                                             
00285700 VALUE LAB;                                                                         
00285800 INTEGER LAB;                                                                       
00285900 %-----------------------------------------------------------------------           
00286000 %                                                                                  
00286100 % USED INTERNALLY TO CONVERT INTEGER TO 4 CHAR DIGITS                              
00286200 %   NEEDED TO SUPPRESS LEADING-ZERO SUPPRESSION...                                 
00286300 %                                                                                  
00286400 %-----------------------------------------------------------------------           
00286500 BEGIN                                                                              
00286600   REPLACE POINTER(T[0]) BY LAB FOR 4 DIGITS;                                       
00286700   DIGITS4:=T[0].[47:32];                                                           
00286800 END; % OF DIGITS4                                                                  
00286900                                                                                    
00287000  $POP OMIT                                                                         
00287100                                                                                    
00287200 PROCEDURE WRITESEGMENT(BUFFER,START,LENGTH,STARTSECTOR);                           
00287300 %         ************                                                             
00287400 %                         IN     IN         OUT                                    
00287500 VALUE START,LENGTH;                                                                
00287600 INTEGER START,LENGTH,STARTSECTOR;                                                  
00287700 REAL ARRAY BUFFER[0];                                                              
00287800 %-----------------------------------------------------------------------           
00287900 %                                                                                  
00288000 % TO WRITE A SEGMENT FROM SEGBUF TO CODE FILE                                      
00288100 %                                                                                  
00288200 %-----------------------------------------------------------------------           
00288300 BEGIN                                                                              
00288400   INTEGER SECTORCOUNT,RESIDUAL;                                                    
00288500   POINTER PBUFFER,PFROM;                                                           
00288600                                                                                    
00288700   PBUFFER:=POINTER(CODEBUF);                                                       
00288800   PFROM:=POINTER(BUFFER[START]);                                                   
00288900   IF ((LENGTH+29) DIV 30) > (CHUNK-(DISKSECTOR MOD CHUNK)) THEN BEGIN              
00289000     SECTORCOUNT:=CHUNK-(DISKSECTOR MOD CHUNK);                                     
00289100     REPLACE PBUFFER BY 0 FOR 30 WORDS;                                             
00289200     THRU SECTORCOUNT DO BEGIN                                                      
00289300       WRITE(CODE,30,CODEBUF[*]);                                                   
00289400     END;                                                                           
00289500     DISKSECTOR:=DISKSECTOR+SECTORCOUNT;                                            
00289600   END;                                                                             
00289700                                                                                    
00289800   IF ((RESIDUAL:=LENGTH MOD 30) NEQ 0) THEN BEGIN                                  
00289900     REPLACE POINTER(BUFFER[START+LENGTH]) BY 0 FOR (30-RESIDUAL) WORDS;            
00290000   END;                                                                             
00290100                                                                                    
00290200   SECTORCOUNT:=(LENGTH+29) DIV 30;                                                 
00290300   THRU SECTORCOUNT DO BEGIN                                                        
00290400     REPLACE PBUFFER BY PFROM:PFROM FOR 30 WORDS;                                   
00290500     WRITE(CODE,30,CODEBUF[*]);                                                     
00290600   END;                                                                             
00290700                                                                                    
00290800   IF HEXCODETOG THEN BEGIN                                                         
00290900     REPLACE LBUF0 BY                                                               
00291000       "DATA WRITTEN TO SECTORS ",                                                  
00291100       DISKSECTOR FOR 5 DIGITS,                                                     
00291200       " TO ",                                                                      
00291300       (DISKSECTOR + SECTORCOUNT - 1) FOR 5 DIGITS;                                 
00291400     WRITETOLINE;                                                                   
00291500   END;                                                                             
00291600   STARTSECTOR:=DISKSECTOR;                                                         
00291700   DISKSECTOR:=DISKSECTOR+SECTORCOUNT;                                              
00291800 END; % OF WRITE SEGMENT                                                            
00291900                                                                                    
00292000                                                                                    
00292100 %***********************************************************************           
00292200 %                                                                                  
00292300 % COMPILER PACKAGE 3 VERSION 1.0  -LINE INFORMATION-                               
00292400 %                                                                                  
00292500 % (C) COPYRIGHT 1976  PROF A.H.J.SALE                                              
00292600 %                     DEPARTMENT OF INFORMATION SCIENCE                            
00292700 %                     UNIVERSITY OF TASMANIA                                       
00292800 %                     BOX 252C  G.P.O.  HOBART  TASMANIA 7001                      
00292900 %                                                                                  
00293000 % ONLY USER-INTERFACE ROUTINE IS "LINEINFO"                                        
00293100 %   OTHER DEFINES, ETC ARE INTERNAL TO PACKAGE                                     
00293200 %                                                                                  
00293300 %***********************************************************************           
00293400                                                                                    
00293500                                                                                    
00293600 %=======================================================================           
00293700 %                                                                                  
00293800 % VARIABLES, ARRAYS AND TRUTHSET                                                   
00293900 %                                                                                  
00294000 %=======================================================================           
00294100                                                                                    
00294200 TRUTHSET                                                                           
00294300         DECDIGITS("0123456789");                                                   
00294400                                                                                    
00294500 INTEGER                                                                            
00294600         LINEBASE,               % BASE OF LINE-NUMS FOR SEGMENT                    
00294700                                                                                    
00294800         LINEINDEX,              % POINT TO NEXT FREE SLOT                          
00294900                                                                                    
00295000         LINECODEADDRESS;        % LAST CODE ADDRESS RECEIVED                       
00295100                                                                                    
00295200 REAL ARRAY                                                                         
00295300         LINETABLE[0:1999],      % TABLE TO HOLD ADDRESSES/LINENUMS                 
00295400                                                                                    
00295500         LINEDICT[0:D1STACKLIMIT],    % HOLDS LINKS (LINEINFO DICTIONARY)           
00295600                                                                                    
00295700         LINEBUF[0:29];          % BUFFER FOR WRITING TO DISK                       
00295800                                                                                    
00295900 %=======================================================================           
00296000 %                                                                                  
00296100 % DEFINES OF FIELDS                                                                
00296200 %                                                                                  
00296300 %=======================================================================           
00296400                                                                                    
00296500 DEFINE                                                                             
00296600         LINEBASEFIELD   =[15:16]#,                                                 
00296700         LINEINDEXFIELD  =[31:16]#,                                                 
00296800         LINECODEFIELD   =[47:16]#,                                                 
00296900                                                                                    
00297000         LINENMBRFIELD   =[31:32]#,                                                 
00297100         LINEADDRFIELD   =[47:16]#;                                                 
00297200                                                                                    
00297300 %=======================================================================           
00297400 %                                                                                  
00297500 % INITIALIZE THE LINEINFO POINTER INDICES                                          
00297600 %                                                                                  
00297700 %=======================================================================           
00297800                                                                                    
00297900 DEFINE LINEINFOINITIALIZE=                                                         
00298000         BEGIN                                                                      
00298100           LINEBASE:=LINEINDEX:=0;                                                  
00298200         END#;                                                                      
00298300                                                                                    
00298400 %=======================================================================           
00298500 %                                                                                  
00298600 % PUSH MARK STACK AND RESET INDICES                                                
00298700 %                                                                                  
00298800 %=======================================================================           
00298900                                                                                    
00299000 DEFINE LINEINFOBEGINSEGMENT=                                                       
00299100         BEGIN                                                                      
00299200           IF (SEGTYPE=CODESEGTYPE) THEN BEGIN                                      
00299300             LINETABLE[LINEINDEX]:= 0                                               
00299400                                    & LINEBASE LINEBASEFIELD                        
00299500                                    & LINEINDEX LINEINDEXFIELD                      
00299600                                    & LINECODEADDRESS LINECODEFIELD;                
00299700             LINEBASE:=LINEINDEX:=(LINEINDEX+1);                                    
00299800             LINECODEADDRESS:=-1;                                                   
00299900           END;                                                                     
00300000         END#;                                                                      
00300100                                                                                    
00300200 %=======================================================================           
00300300 %                                                                                  
00300400 % WRITE LINEINFO FOR SEGMENT AND POP STACK                                         
00300500 %                                                                                  
00300600 %=======================================================================           
00300700                                                                                    
00300800 DEFINE LINEINFOCLOSESEGMENT=                                                       
00300900         BEGIN                                                                      
00301000           IF (SEGTYPE=CODESEGTYPE) THEN BEGIN                                      
00301100             INTEGER LINK,J,LENGTH,ENTRIES;                                         
00301200             POINTER P;                                                             
00301300             % WRITE OUT THE LINKED SECTORS TO CODE FILE                            
00301400             LINK:=0;                                                               
00301500             J:=LINEBASE;                                                           
00301600             LENGTH:=LINEINDEX-LINEBASE;                                            
00301700             WHILE (LENGTH > 0) DO BEGIN                                            
00301800               P:=POINTER(LINEBUF[1]);                                              
00301900               REPLACE P BY 0 FOR 29 WORDS;                                         
00302000               ENTRIES:=MIN(LENGTH,15);                                             
00302100               THRU ENTRIES DO BEGIN                                                
00302200                 REPLACE P:P BY POINTER(LINETABLE[J]) FOR 2,                        
00302300                                48"08",                                             
00302400                         (LINETABLE[J].LINENMBRFIELD) FOR 8 DIGITS;                 
00302500                 J:=J+1;                                                            
00302600               END;                                                                 
00302700               LINEBUF[0]:= 0 & LINK [19:20] & (11*ENTRIES) [39:20];                
00302800               WRITESEGMENT(LINEBUF,0,30,LINK);                                     
00302900               LENGTH:=LENGTH-ENTRIES;                                              
00303000             END;                                                                   
00303100             LINECODEADDRESS:=LINETABLE[LINEBASE-1].LINECODEFIELD;                  
00303200             LINEINDEX:=LINETABLE[LINEBASE-1].LINEINDEXFIELD;                       
00303300             LINEBASE :=LINETABLE[LINEBASE-1].LINEBASEFIELD;                        
00303400             LINEDICT[SEGNUMBER]:=LINK;                                             
00303500           END ELSE BEGIN                                                           
00303600             LINEDICT[SEGNUMBER]:=0;                                                
00303700           END;                                                                     
00303800         END#;                                                                      
00303900                                                                                    
00304000 %=======================================================================           
00304100 %                                                                                  
00304200 % FINALIZE THE LINEINFO BY WRITING DICTIONARY AND LINK                             
00304300 %                                                                                  
00304400 %=======================================================================           
00304500                                                                                    
00304600 DEFINE LINEINFOWRAPUP=                                                             
00304700         BEGIN                                                                      
00304800           INTEGER J;                                                               
00304900           J:=3;                                                                    
00305000           D1ENTRIES:=LASTD1SLOTALLOCATED+1;                                        
00305100           WHILE (J < D1ENTRIES) DO BEGIN                                           
00305200             IF (LINEDICT[J] NEQ 0) THEN BEGIN                                      
00305300               WRITESEGMENT(LINEDICT,0,D1ENTRIES,STARTSEG);                         
00305400               D1STACKTAGS[1]:=5;                                                   
00305500               D1STACK[1]:=0 & 1 [43:1]            % READ-ONLY BIT                  
00305600                             & D1ENTRIES [39:20]   % LENGTH                         
00305700                             & STARTSEG [17:18]    % SECTOR ADDRESS                 
00305800                             & 1 [19:2];           % MCP VALUE ARRAY BIT            
00305900               J:=D1ENTRIES;                                                        
00306000             END;                                                                   
00306100             J:=J+1;                                                                
00306200           END;                                                                     
00306300         END#;                                                                      
00306400                                                                                    
00306500 %=======================================================================           
00306600 %                                                                                  
00306700 % LINEINFO ENTERING PROCEDURE (USER CALLED)                                        
00306800 %                                                                                  
00306900 %=======================================================================           
00307000                                                                                    
00307100 PROCEDURE LINEINFO(LINENUM);                                                       
00307200 %         ********                                                                 
00307300 VALUE LINENUM;                                                                     
00307400 POINTER LINENUM;                                                                   
00307500 BEGIN                                                                              
00307600   INTEGER LINENMBR,CODEADDRESS,K;                                                  
00307700   %                                                                                
00307800   IF (SEGTYPE=CODESEGTYPE) THEN BEGIN                                              
00307900     SCAN LINENUM FOR K:8 WHILE IN DECDIGITS;                                       
00308000     IF (K=0) THEN BEGIN                                                            
00308100       LINENMBR:=INTEGER(LINENUM,8);                                                
00308200       CODEADDRESS:=0 & (SEGWORDINDEX-SEGMENTBASE) [15:13]                          
00308300         & SEGSYLINDEX [2:3];                                                       
00308400       IF (LINECODEADDRESS = CODEADDRESS) THEN BEGIN                                
00308500         IF (LINEBASE NEQ LINEINDEX) THEN BEGIN   %TESTING FOR BUG                  
00308600           LINETABLE[LINEINDEX-1]:= * & LINENMBR LINENMBRFIELD;                     
00308700         END;                                                                       
00308800       END ELSE BEGIN                                                               
00308900         LINETABLE[LINEINDEX]:=LINENMBR & CODEADDRESS LINEADDRFIELD;                
00309000         LINEINDEX:=LINEINDEX+1;                                                    
00309100         LINECODEADDRESS:=CODEADDRESS;                                              
00309200       END;                                                                         
00309300     END;                                                                           
00309400   END;                                                                             
00309500 END; % OF LINE INFO                                                                
00309600                                                                                    
00309700 %=======================================================================           
00309800 %   BINDINFO PROCEDURES                                                            
00309900 %=======================================================================           
00310000                                                                                    
00310100 PROCEDURE BUILDITEMDESC(FIP,BLOCKS);                                               
00310200 %         *************                                                            
00310300 VALUE FIP,BLOCKS;                                                                  
00310400 TYPEIDENTPTR FIP;                                                                  
00310500 INTEGER BLOCKS;                                                                    
00310600 BEGIN                                                                              
00310700 INTEGER                                                                            
00310800   SAVEBINDEX;                                                                      
00310900                                                                                    
00311000 PROCEDURE BLDCNTARRAY;                                                             
00311100 %         ***********                                                              
00311200 BEGIN                                                                              
00311300   BITPICKER:=0;                                                                    
00311400   DIRECTORY[BINDEX+1]:=BITPICKER;                                                  
00311500   IF BOOLEAN(BLOCKS.[PARAMS:1]) OR (LEXLEVEL=2) THEN BEGIN                         
00311600     BITPICKER.SCV:=15;                                                             
00311700   END ELSE BEGIN                                                                   
00311800     BITPICKER.SCV:=27;                                                             
00311900   END;                                                                             
00312000   BITPICKER.NWORDS:=1;                                                             
00312100   DIRECTORY[BINDEX]:=BITPICKER;                                                    
00312200   DIRECTORY[BINDEX+1] := 0 & 1 [7:8];                                              
00312300   BINDEX:=BINDEX+2;                                                                
00312400 END;                                                                               
00312500                                                                                    
00312600 PROCEDURE BUILDID(FIP);                                                            
00312700 %         *******                                                                  
00312800 VALUE FIP;                                                                         
00312900 TYPEIDENTPTR FIP;                                                                  
00313000 BEGIN                                                                              
00313100 INTEGER                                                                            
00313200   LEN;                                                                             
00313300   BITPICKER := 0 & 1 SCV                                                           
00313400                  & (1+((LEN:=HEAP[NAME(FIP)].[47:8]-1) + 3) DIV                    
00313500                         CHARSPERWORD) NWORDS;                                      
00313600   DIRECTORY[BINDEX]:=BITPICKER;                                                    
00313700   DIRECTORY[BINDEX+1].[47:8] := LEN+4;                                             
00313800   DIRECTORY[BINDEX+1].[39:8] := 1;                                                 
00313900   DIRECTORY[BINDEX+1].[31:8] := 1;                                                 
00314000   DIRECTORY[BINDEX+1].[23:8] := LEN;                                               
00314100   REPLACE POINTER(DIRECTORY[BINDEX+1])+4 BY                                        
00314200       POINTER(HEAP[NAME(FIP)])+1 FOR LEN;                                          
00314300   BINDEX:=BINDEX+((LEN+3) DIV CHARSPERWORD+1)+1;                                   
00314400 END;   %OF BUILDID                                                                 
00314500                                                                                    
00314600 PROCEDURE BUILDADR(FIP);                                                           
00314700 %         ********                                                                 
00314800 VALUE FIP;                                                                         
00314900 TYPEIDENTPTR FIP;                                                                  
00315000 BEGIN                                                                              
00315100   BITPICKER := 0 & 1 NWORDS & 2 SCV;                                               
00315200   DIRECTORY[BINDEX]:=BITPICKER;                                                    
00315300   IF INTEST(KLASS(FIP),PRCFNCSET) THEN BEGIN                                       
00315400     IF BOOLEAN(BLOCKS.[FUNCVAR:1]) THEN BEGIN                                      
00315500       BITPICKER.SCV := LEXLEVEL;                                                   
00315600       BITPICKER.NWORDS := FNCDPLMT(FIP);                                           
00315700     END ELSE BEGIN                                                                 
00315800       BITPICKER.SCV := PFLEV(FIP);                                                 
00315900       BITPICKER.NWORDS := PFDPLMT(FIP);                                            
00316000     END;                                                                           
00316100   END ELSE BEGIN                                                                   
00316200     BITPICKER.SCV:=VLEV(FIP);                                                      
00316300     BITPICKER.NWORDS := VADDR(FIP);                                                
00316400   END;                                                                             
00316500   IF (BITPICKER.SCV < 3) THEN CHANGENEEDED := TRUE;                                
00316600   DIRECTORY[BINDEX+1]:=BITPICKER;                                                  
00316700   BINDEX:=BINDEX+2;                                                                
00316800 END;   %OF BUILDADR                                                                
00316900                                                                                    
00317000 PROCEDURE BUILDMPCW(FIP);                                                          
00317100 %         *********                                                                
00317200 VALUE FIP;                                                                         
00317300 TYPEIDENTPTR FIP;                                                                  
00317400 BEGIN                                                                              
00317500   BITPICKER:=0 & 7 SCV & 1 NWORDS;                                                 
00317600   DIRECTORY[BINDEX]:=BITPICKER;                                                    
00317700   DIRECTORY[BINDEX+1]:=MPCWP(FIP);                                                 
00317800   BINDEX := *+2;                                                                   
00317900 END;   %OF BUILDMPCW;                                                              
00318000                                                                                    
00318100 PROCEDURE BUILDPARAMS(FIP);                                                        
00318200 %         ***********                                                              
00318300 VALUE FIP;                                                                         
00318400 TYPEIDENTPTR FIP;                                                                  
00318500 BEGIN                                                                              
00318600 INTEGER                                                                            
00318700   SAVEBINDEX,COUNT;                                                                
00318800 SAVEBINDEX := BINDEX;                                                              
00318900 BINDEX := *+3;                                                                     
00319000 WHILE (FIP NEQ NIL) DO BEGIN                                                       
00319100   COUNT := *+1;                                                                    
00319200   BUILDITEMDESC(FIP,0 & 1[PARAMS:1]);                                              
00319300   FIP := NEXT(FIP);                                                                
00319400 END;                                                                               
00319500 BITPICKER := 0 & 3 SCV;                                                            
00319600 DIRECTORY[SAVEBINDEX]:=BITPICKER;                                                  
00319700 IF (COUNT > 0) THEN BEGIN                                                          
00319800   BITPICKER.NWORDS := BINDEX - SAVEBINDEX - 1;                                     
00319900   DIRECTORY[SAVEBINDEX] := BITPICKER;                                              
00320000   BITPICKER := 0 & 9 SCV & 1 NWORDS;                                               
00320100   DIRECTORY[SAVEBINDEX+1] := BITPICKER;                                            
00320200   DIRECTORY[SAVEBINDEX+2] := COUNT;                                                
00320300   BITPICKER := 0;                                                                  
00320400 END ELSE BEGIN                                                                     
00320500   BINDEX := BINDEX - 2;                                                            
00320600 END;                                                                               
00320700 END;   %OF BUILDPARAMS                                                             
00320800                                                                                    
00320900 %                                                                                  
00321000 %   BUILDITEMDESC                                                                  
00321100 %                                                                                  
00321200                                                                                    
00321300 IF (FIP NEQ NIL) THEN BEGIN                                                        
00321400   SAVEBINDEX := BINDEX;                                                            
00321500   BINDEX := BINDEX+1;                                                              
00321600   IF BOOLEAN(BLOCKS.[IDBUILD:1]) THEN BEGIN                                        
00321700     BUILDID(FIP);                                                                  
00321800   END;                                                                             
00321900   IF BOOLEAN(BLOCKS.[ADRBUILD:1]) THEN BEGIN                                       
00322000     BUILDADR(FIP);                                                                 
00322100   END;                                                                             
00322200   BITPICKER := 0;                                                                  
00322300   CASE KLASS(FIP) OF BEGIN                                                         
00322400   VARS:                                                                            
00322500     CASE FORM(IDTYPE(FIP)) OF BEGIN                                                
00322600     SCALAR: SUBRANGE: POINTERS:                                                    
00322700       IF (IDTYPE(FIP)=REALPTR) THEN BITPICKER.SCV := 1                             
00322800       ELSE IF (IDTYPE(FIP)=BOOLPTR) THEN BITPICKER.SCV := 2                        
00322900            ELSE BITPICKER.SCV:=0;                                                  
00323000       BITPICKER.UCV := 2;                                                          
00323100       BITPICKER.[40:1] := VKIND(FIP);                                              
00323200     POWER:                                                                         
00323300       IF SHORTSET(IDTYPE(FIP)) THEN BEGIN                                          
00323400         BITPICKER := 0 & 2 UCV                                                     
00323500                        & VKIND(FIP) [40:1];                                        
00323600       END ELSE BEGIN                                                               
00323700         IF (VKIND(FIP)=FORMAL) OR NOT BOOLEAN(BLOCKS.[PARAMS:1]) THEN              
00323800         BEGIN                                                                      
00323900           BLDCNTARRAY;                                                             
00324000           BITPICKER := 0 & 6 UCV                                                   
00324100                          & VKIND(FIP) [40:1];                                      
00324200         END ELSE BEGIN                                                             
00324300           BITPICKER := 0 & 16 UCV & 1 SCV;                                         
00324400         END;                                                                       
00324500       END;                                                                         
00324600     ARRAYS: RECORDS:                                                               
00324700       IF (VKIND(FIP)=FORMAL) OR NOT BOOLEAN(BLOCKS.[PARAMS:1]) THEN                
00324800       BEGIN                                                                        
00324900         BLDCNTARRAY;                                                               
00325000         IF (BITS(IDTYPE(FIP))=BITSPERWORD) OR(BITS(IDTYPE(FIP))=1)THEN             
00325100         BEGIN                                                                      
00325200           BITPICKER := 0 & 6 UCV & 1 SCV;                                          
00325300         END ELSE BEGIN                                                             
00325400           BITPICKER := 0 & 14 UCV &                                                
00325500                           (IF (BITS(IDTYPE(FIP))=8) THEN 3                         
00325600                            ELSE IF(BITS(IDTYPE(FIP))=6) THEN 2                     
00325700                                 ELSE 1) SCV;                                       
00325800         END;                                                                       
00325900         BITPICKER.[40:1] := VKIND(FIP);                                            
00326000       END ELSE BEGIN                                                               
00326100         BITPICKER := 0 & 16 UCV & 1 SCV;                                           
00326200       END;                                                                         
00326300     FILES:                                                                         
00326400       BITPICKER := 0 & 22 UCV & 1 SCV                                              
00326500                      & VKIND(FIP) [40:1];                                          
00326600     END;                                                                           
00326700   PROC: FUNC:                                                                      
00326800     IF (NOT(BOOLEAN(BLOCKS.[PARAMS:1]))) OR (PFKIND(FIP)=FORMAL) THEN              
00326900     BEGIN                                                                          
00327000       BUILDPARAMS(IF (PFKIND(FIP)=FORMAL) THEN FPARAMLIST(FIP)                     
00327100                   ELSE NEXT(FIP));                                                 
00327200     END;                                                                           
00327300     IF (BOOLEAN(BLOCKS.[MPCWBUILD:1])) THEN BEGIN                                  
00327400       BUILDMPCW(FIP);                                                              
00327500     END;                                                                           
00327600     BITPICKER := 0;                                                                
00327700     IF (KLASS(FIP)=PROC) THEN BEGIN                                                
00327800       BITPICKER := * & 18 UCV & 0 SCV;                                             
00327900     END ELSE BEGIN                                                                 
00328000       BITPICKER.UCV := IF BOOLEAN(BLOCKS.[FUNCVAR:1]) THEN 2 ELSE 20;              
00328100       BITPICKER.SCV := IF (IDTYPE(FIP)=REALPTR) THEN 1                             
00328200                        ELSE IF (IDTYPE(FIP)=BOOLPTR) THEN 2                        
00328300                             ELSE 0;                                                
00328400     END;                                                                           
00328500   END;   %OF CASE                                                                  
00328600   BITPICKER.NWORDS := BINDEX-SAVEBINDEX-1;                                         
00328700   DIRECTORY[SAVEBINDEX]:=BITPICKER;                                                
00328800 END;                                                                               
00328900 END;   %OF BUILDITEMDESC                                                           
00329000                                                                                    
00329100 PROCEDURE BUILDLOCALDIRECTORY(FIP,STACKHEAD);                                      
00329200 %         *******************                                                      
00329300 VALUE FIP,STACKHEAD;                                                               
00329400 TYPEIDENTPTR FIP;                                                                  
00329500 TYPESTACKPTR STACKHEAD;                                                            
00329600 BEGIN                                                                              
00329700 INTEGER                                                                            
00329800   SAVEBINDEX,LD;                                                                   
00329900 TYPEIDENTPTR                                                                       
00330000   LIP;                                                                             
00330100 SAVEBINDEX := BINDEX;                                                              
00330200 BINDEX := *+1;                                                                     
00330300 CHANGENEEDED := FALSE;                                                             
00330400 IF (FIP NEQ NIL) THEN BEGIN                                                        
00330500   IF (KLASS(FIP)=FUNC) THEN BEGIN                                                  
00330600     BUILDITEMDESC(FIP,0 & 1[IDBUILD:1] & 1[ADRBUILD:1]                             
00330700                         & 1[PARAMS:1] & 1[FUNCVAR:1]);                             
00330800   END;                                                                             
00330900   LIP := NEXT(FIP);                                                                
00331000   WHILE (LIP NEQ NIL) DO BEGIN                                                     
00331100     BUILDITEMDESC(LIP,0 & 1[IDBUILD:1] & 1[ADRBUILD:1]                             
00331200                         & 1[MPCWBUILD:1]);                                         
00331300     LIP := NEXT(LIP);                                                              
00331400   END;                                                                             
00331500 END;                                                                               
00331600 LIP := STACKHEAD;                                                                  
00331700 WHILE (LIP NEQ NIL) DO BEGIN                                                       
00331800   IF (BUILDID(LIP) NEQ FIP) THEN BEGIN                                             
00331900     BUILDITEMDESC(BUILDID(LIP),0 & 1[IDBUILD:1] & 1[ADRBUILD:1]                    
00332000                                  & 1[MPCWBUILD:1]);                                
00332100   END;                                                                             
00332200   LIP := BUILDPTR(LIP);                                                            
00332300 END;                                                                               
00332400 BITPICKER := 0 & 33 SCV                                                            
00332500                & (BINDEX-SAVEBINDEX-1) NWORDS;                                     
00332600 DIRECTORY[SAVEBINDEX] := BITPICKER;                                                
00332700 WRITESEGMENT(DIRECTORY,0,BINDEX,LD);                                               
00332800 BITPICKER := 0 & LD LDIRSEGMENT & SAVEBINDEX OFFSET                                
00332900                & REAL(CHANGENEEDED) CBIT;                                          
00333000 BINDEX := 0;                                                                       
00333100 END;   %OF BUILDLOCALDIRECTORY                                                     
00333200                                                                                    
00333300 PROCEDURE BUILDPROCEDUREDIRECTORY(FIP);                                            
00333400 %         ***********************                                                  
00333500 VALUE FIP;                                                                         
00333600 TYPEIDENTPTR FIP;                                                                  
00333700 BEGIN                                                                              
00333800 INTEGER                                                                            
00333900   LEN,LSEG;                                                                        
00334000 LEN := HEAP[NAME(FIP)].[47:8]-1;                                                   
00334100 IF (LASTPROCDIREC < (LEN DIV CHARSPERWORD) + 2) THEN BEGIN                         
00334200   PNWORDS := PNWORDS + 29 - LASTPROCDIREC;                                         
00334300   REPLACE POINTER(PDIRECTORY[1]) BY POINTER(PDIRECTORY[LASTPROCDIREC+1])           
00334400     FOR (29-LASTPROCDIREC)*CHARSPERWORD;                                           
00334500   WRITESEGMENT(PDIRECTORY,0,(30-LASTPROCDIREC) ,LSEG);                             
00334600   BITPICKER := 0 & (29-LASTPROCDIREC) SCV                                          
00334700                  & LSEG NWORDS;                                                    
00334800   PDIRECTORY[0] := BITPICKER;                                                      
00334900   LASTPROCDIREC := 29;                                                             
00335000 END;                                                                               
00335100 LASTPROCDIREC := LASTPROCDIREC - (2+ LEN DIV CHARSPERWORD);                        
00335200 PDIRECTORY[LASTPROCDIREC+2].[47:8] := LEN;                                         
00335300 REPLACE POINTER(PDIRECTORY[LASTPROCDIREC+2])+1 BY                                  
00335400   POINTER(HEAP[NAME(FIP)])+1 FOR LEN;                                              
00335500 BITPICKER := * & LEXLEVEL LDIRLL                                                   
00335600                & BINDIN(FIP) EXBIT                                                 
00335700                & MPCWP(FIP) CODEPAGE;                                              
00335800 PDIRECTORY[LASTPROCDIREC+1] := BITPICKER;                                          
00335900 END;   %OF BUILDPROCEDUREDIRECTORY                                                 
00336000                                                                                    
00336100 INTEGER PROCEDURE BLDPROGRAMDESCRIPTION;                                           
00336200 %                 *********************                                            
00336300 BEGIN                                                                              
00336400 INTEGER                                                                            
00336500   LSEG,I;                                                                          
00336600                                                                                    
00336700 PROCEDURE MAKEFIBPTRS;                                                             
00336800 %         ***********                                                              
00336900 BEGIN                                                                              
00337000 INTEGER I;                                                                         
00337100 BITPICKER := 0 & 14 SCV & FIBPTR NWORDS;                                           
00337200 DIRECTORY[BINDEX] := BITPICKER;                                                    
00337300 FOR I:=0 STEP 1 UNTIL (FIBPTR-1) DO BEGIN                                          
00337400   DIRECTORY[BINDEX+I+1] := FIBPTRS[I];                                             
00337500 END;                                                                               
00337600 BINDEX := BINDEX+FIBPTR+1;                                                         
00337700 END;   %OF MAKEFIBPTRS                                                             
00337800                                                                                    
00337900 IF BINDINFOTOG THEN BEGIN                                                          
00338000   BITPICKER := 0;                                                                  
00338100   BINDEX := 0;                                                                     
00338200   BUILDITEMDESC(OBPROCP,0 & 1[IDBUILD:1] & 1[ADRBUILD:1]);                         
00338300   BITPICKER := 0;                                                                  
00338400   IF (FIBPTR > 0) THEN BEGIN                                                       
00338500     MAKEFIBPTRS;                                                                   
00338600   END;                                                                             
00338700 %                                                                                  
00338800   BITPICKER := 0 & 1 NWORDS & 25 SCV;                                              
00338900   DIRECTORY[BINDEX]:=BITPICKER;                                                    
00339000   DIRECTORY[BINDEX+1]:=BEXITPTR;                                                   
00339100   BINDEX := *+2;                                                                   
00339200 %                                                                                  
00339300   BITPICKER := * & 19 SCV;                                                         
00339400   DIRECTORY[BINDEX] := BITPICKER;                                                  
00339500   DIRECTORY[BINDEX+1] := FIRSTEXECCODE;                                            
00339600   BINDEX := *+2;                                                                   
00339700 %                                                                                  
00339800   BITPICKER := * & 18 SCV;                                                         
00339900   DIRECTORY[BINDEX] := BITPICKER;                                                  
00340000   DIRECTORY[BINDEX+1] := ENDOFD2CODE;                                              
00340100   BINDEX := *+2;                                                                   
00340200 %                                                                                  
00340300   BITPICKER := * & 21 SCV;                                                         
00340400   DIRECTORY[BINDEX] := BITPICKER;                                                  
00340500   BITPICKER := STACKCELLS[2];                                                      
00340600   DIRECTORY[BINDEX+1] := BITPICKER;                                                
00340700   BITPICKER := 1;                                                                  
00340800   BINDEX := *+2;                                                                   
00340900 %                                                                                  
00341000   BITPICKER := * & 42 SCV;                                                         
00341100   DIRECTORY[BINDEX] := BITPICKER;                                                  
00341200   DIRECTORY[BINDEX+1] := SCWIMAGE;                                                 
00341300   BINDEX := *+2;                                                                   
00341400 %                                                                                  
00341500   BITPICKER := 0 & 34 SCV                                                          
00341600                  & (PNWORDS+29-LASTPROCDIREC) NWORDS;                              
00341700   REPLACE POINTER(PDIRECTORY[1]) BY POINTER(PDIRECTORY[LASTPROCDIREC+1])           
00341800     FOR (29-LASTPROCDIREC) WORDS;                                                  
00341900   WRITESEGMENT(PDIRECTORY,0,(30-LASTPROCDIREC),LSEG);                              
00342000   DIRECTORY[BINDEX]:=BITPICKER;                                                    
00342100   BITPICKER := * & (29-LASTPROCDIREC) SCV                                          
00342200                  & LSEG NWORDS;                                                    
00342300   DIRECTORY[BINDEX+1] := BITPICKER;                                                
00342400   BITPICKER := * & 4 SCV & 0 NWORDS;                                               
00342500   DIRECTORY[BINDEX + 2] := BITPICKER;                                              
00342600   BINDEX := *+3;                                                                   
00342700 %                                                                                  
00342800   BITPICKER := 0;                                                                  
00342900   DIRECTORY[BINDEX] := BITPICKER;                                                  
00343000   WRITESEGMENT(DIRECTORY,0,BINDEX,LSEG);                                           
00343100   BITPICKER := * & BINDEX SCV & LSEG NWORDS;                                       
00343200   BLDPROGRAMDESCRIPTION := BITPICKER;                                              
00343300 END ELSE BEGIN                                                                     
00343400   BLDPROGRAMDESCRIPTION := 0;                                                      
00343500 END;                                                                               
00343600 END;   %OF BLDPROGRAMDESCRIPTION                                                   
00343700                                                                                    
00343800                                                                                    
00343900 %***********************************************************************           
00344000 %                                                                                  
00344100 % COMPILER PACKAGE 2 VERSION 1.0  -CODE GENERATION-                                
00344200 %                                                                                  
00344300 % CODE ROUTINES                                                                    
00344400 %                                                                                  
00344500 % (C) COPYRIGHT  PROF A.H.J.SALE                                                   
00344600 %                DEPARTMENT OF INFORMATION SCIENCE                                 
00344700 %                UNIVERSITY OF TASMANIA                                            
00344800 %                BOX 252C G.P.O.  HOBART  TASMANIA 7001                            
00344900 %                                                                                  
00345000 % MOSTLY USER-INTERFACE ROUTINES                                                   
00345100 %   WILL NOT NEED USER-MODIFICATION                                                
00345200 %                                                                                  
00345300 %***********************************************************************           
00345400                                                                                    
00345500                                                                                    
00345600 PROCEDURE GENSYL(SYL);                                                             
00345700 %         ******                                                                   
00345800 VALUE SYL;                                                                         
00345900 INTEGER SYL;                                                                       
00346000 BEGIN                                                                              
00346100   CASE SEGSYLINDEX.[2:3] OF BEGIN                                                  
00346200     0: SEGBUF[SEGWORDINDEX]:= * & SYL [47:8];                                      
00346300     1: SEGBUF[SEGWORDINDEX]:= * & SYL [39:8];                                      
00346400     2: SEGBUF[SEGWORDINDEX]:= * & SYL [31:8];                                      
00346500     3: SEGBUF[SEGWORDINDEX]:= * & SYL [23:8];                                      
00346600     4: SEGBUF[SEGWORDINDEX]:= * & SYL [15:8];                                      
00346700     5: BEGIN                                                                       
00346800          SEGBUF[SEGWORDINDEX]:= * & SYL [7:8];                                     
00346900          IF HEXCODETOG THEN BEGIN                                                  
00347000            FORMATWORD(SEGBUF[SEGWORDINDEX]);                                       
00347100            WRITETOLINE;                                                            
00347200          END; % OF IF                                                              
00347300          SEGSYLINDEX:= -1;  SEGWORDINDEX:= *+1;                                    
00347400        END; % OF ACTION FOR 5                                                      
00347500   END; % OF CASE                                                                   
00347600   SEGSYLINDEX:= *+1;                                                               
00347700 END; % OF GENSYL                                                                   
00347800                                                                                    
00347900                                                                                    
00348000 PROCEDURE GENWORD(WORD);                                                           
00348100 %         *******                                                                  
00348200 VALUE WORD;                                                                        
00348300 REAL WORD;                                                                         
00348400 BEGIN                                                                              
00348500  $SET OMIT = NOT DEBUG                                                             
00348600   IF (SEGSYLINDEX NEQ 0) THEN BEGIN                                                
00348700     CERROR(1);                                                                     
00348800   END;                                                                             
00348900  $POP OMIT                                                                         
00349000   SEGBUF[SEGWORDINDEX]:=WORD;                                                      
00349100   IF HEXCODETOG THEN BEGIN                                                         
00349200     FORMATWORD(WORD);                                                              
00349300     WRITETOLINE;                                                                   
00349400   END;                                                                             
00349500   SEGWORDINDEX:= *+1;                                                              
00349600 END; % OF GENWORD                                                                  
00349700                                                                                    
00349800                                                                                    
00349900                                                                                    
00350000 PROCEDURE GENLT48(OP,WORD);                                                        
00350100 %         *******                                                                  
00350200 VALUE OP,WORD;                                                                     
00350300 INTEGER OP;                                                                        
00350400 REAL WORD;                                                                         
00350500 BEGIN                                                                              
00350600  $SET OMIT = NOT DEBUG                                                             
00350700   IF NOT((OP=4"BE") OR (OP=4"BF")) THEN CERROR(7);                                 
00350800  $POP OMIT                                                                         
00350900   IF CODETOG THEN BEGIN                                                            
00351000     FORMATADDRESS;                                                                 
00351100     REPLACE H[0] BY WORD.[47:48] FOR 12;                                           
00351200     REPLACE LBUF0+60 BY                                                            
00351300       OPNAME[OP-4"80"].[31:48] FOR 4,                                              
00351400       " (#",                                                                       
00351500       H[0] FOR 12 WITH HEXTOEBCDIC,                                                
00351600       ")";                                                                         
00351700     WRITETOLINE;                                                                   
00351800   END;                                                                             
00351900   GENSYL(OP);                                                                      
00352000   WHILE (SEGSYLINDEX NEQ 0) DO BEGIN                                               
00352100     GENSYL(4"FF");                                                                 
00352200   END; % OF WHILE                                                                  
00352300   GENWORD(WORD);                                                                   
00352400 END; % OF GENLT48                                                                  
00352500                                                                                    
00352600                                                                                    
00352700 PROCEDURE GENOP(OP);                                                               
00352800 %         *****                                                                    
00352900 VALUE OP;                                                                          
00353000 INTEGER OP;                                                                        
00353100 BEGIN                                                                              
00353200   IF (OP > 4"FF") THEN BEGIN                                                       
00353300     IF (OP.[47:40] IS 1) THEN BEGIN                                                
00353400       OP:=OP.BYTEMASK;                                                             
00353500       IF CODETOG THEN BEGIN                                                        
00353600         FORMATPRIMARY(VARNAME[OP-4"40"]);                                          
00353700         WRITETOLINE;                                                               
00353800       END;                                                                         
00353900       GENSYL(4"95"); GENSYL(OP);                                                   
00354000     END ELSE IF (OP.[47:40] IS 4) THEN BEGIN                                       
00354100       OP:=OP.BYTEMASK;                                                             
00354200       IF CODETOG THEN BEGIN                                                        
00354300         FORMATPRIMARY(VECNAME[OP-4"E0"]);                                          
00354400         WRITETOLINE;                                                               
00354500         IF (OP=4"E6") THEN BEGIN                                                   
00354600           REPLACE LBUF0+60 BY                                                      
00354700             "EXIT VECTOR MODE";                                                    
00354800           WRITETOLINE;                                                             
00354900         END;                                                                       
00355000       END;                                                                         
00355100       GENSYL(OP);                                                                  
00355200     END ELSE BEGIN                                                                 
00355300       CERROR(17);                                                                  
00355400     END;                                                                           
00355500   END ELSE BEGIN                                                                   
00355600     IF CODETOG THEN BEGIN                                                          
00355700       FORMATPRIMARY(OPNAME[OP-4"80"]);                                             
00355800       WRITETOLINE;                                                                 
00355900       IF (OP=VMES) THEN BEGIN                                                      
00356000         REPLACE LBUF0 BY " " FOR 60,                                               
00356100           "VECTORMODE FOR NEXT WORD";                                              
00356200         WRITETOLINE;                                                               
00356300       END;                                                                         
00356400       IF (OP=VMEN) THEN BEGIN                                                      
00356500         REPLACE LBUF0 BY " " FOR 60,                                               
00356600           "ENTER VECTOR MODE";                                                     
00356700         WRITETOLINE;                                                               
00356800       END;                                                                         
00356900     END;                                                                           
00357000     GENSYL(OP);                                                                    
00357100   END;                                                                             
00357200 END; % OF GENOP                                                                    
00357300                                                                                    
00357400                                                                                    
00357500 PROCEDURE GENOP1(OP,SYL1);                                                         
00357600 %         ******                                                                   
00357700 VALUE OP,SYL1;                                                                     
00357800 INTEGER OP,SYL1;                                                                   
00357900 BEGIN                                                                              
00358000  $SET OMIT = NOT DEBUG                                                             
00358100   IF (SYL1 > 4"FF") THEN CERROR(10);                                               
00358200  $POP OMIT                                                                         
00358300   IF CODETOG THEN BEGIN                                                            
00358400     FORMATADDRESS;                                                                 
00358500     REPLACE H[9] BY SYL1.[7:48] FOR 2;                                             
00358600     REPLACE LBUF0 +60 BY                                                           
00358700       OPNAME[OP-4"80"].[31:48] FOR 4,                                              
00358800       " (",                                                                        
00358900       SYL1 FOR 3 DIGITS,                                                           
00359000       ")    #",                                                                    
00359100       H[9] FOR 2 WITH  HEXTOEBCDIC;                                                
00359200     WRITETOLINE;                                                                   
00359300   END;                                                                             
00359400   GENSYL(OP);  GENSYL(SYL1);                                                       
00359500 END; % OF GENOP1                                                                   
00359600                                                                                    
00359700                                                                                    
00359800 PROCEDURE GENOP2(OP,SYL1,SYL2);                                                    
00359900 %         ******                                                                   
00360000 VALUE OP,SYL1,SYL2;                                                                
00360100 INTEGER OP,SYL1,SYL2;                                                              
00360200 BEGIN                                                                              
00360300  $SET OMIT = NOT DEBUG                                                             
00360400   IF (SYL1>4"FF") OR (SYL2>4"FF") THEN CERROR(10);                                 
00360500  $POP OMIT                                                                         
00360600   IF CODETOG THEN BEGIN                                                            
00360700     FORMATADDRESS;                                                                 
00360800     REPLACE LBUF0+60 BY                                                            
00360900       OPNAME[OP-4"80"].[31:48] FOR 4,                                              
00361000       " (",                                                                        
00361100       SYL1 FOR 2 DIGITS,                                                           
00361200       ",",                                                                         
00361300       SYL2 FOR 2 DIGITS,                                                           
00361400       ")";                                                                         
00361500     WRITETOLINE;                                                                   
00361600   END;                                                                             
00361700   GENSYL(OP);  GENSYL(SYL1);  GENSYL(SYL2);                                        
00361800 END; % OF GENOP2                                                                   
00361900                                                                                    
00362000                                                                                    
00362100 PROCEDURE GENFLTR(SYL1,SYL2,SYL3);                                                 
00362200 %         *******                                                                  
00362300 VALUE SYL1,SYL2,SYL3;                                                              
00362400 INTEGER SYL1,SYL2,SYL3;                                                            
00362500 BEGIN                                                                              
00362600  $SET OMIT = NOT DEBUG                                                             
00362700   IF (SYL1 > 4"FF") OR                                                             
00362800      (SYL2 > 4"FF") OR                                                             
00362900      (SYL3 > 4"FF") THEN                                                           
00363000        CERROR(10);                                                                 
00363100  $POP OMIT                                                                         
00363200   IF CODETOG THEN BEGIN                                                            
00363300     FORMATADDRESS;                                                                 
00363400     REPLACE LBUF0+60 BY                                                            
00363500       "FLTR (",                                                                    
00363600       SYL1 FOR 2 DIGITS,                                                           
00363700       ",",                                                                         
00363800       SYL2 FOR 2 DIGITS,                                                           
00363900       ",",                                                                         
00364000       SYL3 FOR 2 DIGITS,                                                           
00364100       ")";                                                                         
00364200     WRITETOLINE;                                                                   
00364300   END;                                                                             
00364400   GENSYL(4"98");                                                                   
00364500   GENSYL(SYL1);  GENSYL(SYL2); GENSYL(SYL3);                                       
00364600 END; % OF GENFLTR                                                                  
00364700                                                                                    
00364800                                                                                    
00364900 PROCEDURE GENLT16(VAL);                                                            
00365000 %         *******                                                                  
00365100 VALUE VAL;                                                                         
00365200 INTEGER VAL;                                                                       
00365300 BEGIN                                                                              
00365400  $SET OMIT = NOT DEBUG                                                             
00365500   IF (VAL.[47:32] ISNT 0) THEN CERROR(8);                                          
00365600  $POP OMIT                                                                         
00365700   IF CODETOG THEN BEGIN                                                            
00365800     FORMATADDRESS;                                                                 
00365900     REPLACE H[0] BY VAL.[15:48] FOR 4;                                             
00366000     REPLACE LBUF0+60 BY                                                            
00366100       "LT16 (",                                                                    
00366200       VAL FOR 5 DIGITS,                                                            
00366300       ")  #",                                                                      
00366400       H[0] FOR 4 WITH HEXTOEBCDIC;                                                 
00366500     WRITETOLINE;                                                                   
00366600   END;                                                                             
00366700   GENSYL(4"B3");                                                                   
00366800   GENSYL(VAL.[15:8]);                                                              
00366900   GENSYL(VAL.[07:8]);                                                              
00367000 END; % OF GENLT16                                                                  
00367100                                                                                    
00367200                                                                                    
00367300 PROCEDURE WORDBOUNDARY;                                                            
00367400 %         ************                                                             
00367500 BEGIN                                                                              
00367600   WHILE (SEGSYLINDEX NEQ 0) DO BEGIN                                               
00367700     GENSYL(4"FF");                                                                 
00367800   END;                                                                             
00367900 END; % OF WORDBOUNDARY                                                             
00368000                                                                                    
00368100                                                                                    
00368200 PROCEDURE GENV(OP,LXLVL,DISPLACEMENT);                                             
00368300 %         ****                                                                     
00368400 VALUE OP,LXLVL,DISPLACEMENT;                                                       
00368500 INTEGER OP,LXLVL,DISPLACEMENT;                                                     
00368600 BEGIN                                                                              
00368700   REAL VALUE ARRAY LEXLEVELINFO(                                                   
00368800   %---------------------------------------------------------------------           
00368900   % FIRST FIELD IS BIT-REVERSED LEXICAL LEVEL                                      
00369000   % SECOND FIELD IS MAXIMUM DISPLACEMENT AT THIS LEVEL                             
00369100   %---------------------------------------------------------------------           
00369200     4"0000" 4"1FFF", 4"2000" 4"1FFF", 4"1000" 4"0FFF", 4"3000" 4"0FFF",            
00369300     4"0800" 4"07FF", 4"2800" 4"07FF", 4"1800" 4"07FF", 4"3800" 4"07FF",            
00369400     4"0400" 4"03FF", 4"2400" 4"03FF", 4"1400" 4"03FF", 4"3400" 4"03FF",            
00369500     4"0C00" 4"03FF", 4"2C00" 4"03FF", 4"1C00" 4"03FF", 4"3C00" 4"03FF",            
00369600     4"0200" 4"01FF", 4"2200" 4"01FF", 4"1200" 4"01FF", 4"3200" 4"01FF",            
00369700     4"0A00" 4"01FF", 4"2A00" 4"01FF", 4"1A00" 4"01FF", 4"3A00" 4"01FF",            
00369800     4"0600" 4"01FF", 4"2600" 4"01FF", 4"1600" 4"01FF", 4"3600" 4"01FF",            
00369900     4"0E00" 4"01FF", 4"2E00" 4"01FF", 4"1E00" 4"01FF", 4"3E00" 4"01FF");           
00370000                                                                                    
00370100   DEFINE                                                                           
00370200     MAXIMUMFORLEXLEVEL=LEXLEVELINFO[LEXLEVEL].[12:13]#,                            
00370300     BITREVERSEDLEXLEVEL=LEXLEVELINFO[LXLVL].[29:14]#;                              
00370400                                                                                    
00370500  $SET OMIT = NOT DEBUG                                                             
00370600   IF (LXLVL > LEXLEVEL) THEN CERROR(2);                                            
00370700   IF (DISPLACEMENT > MAXIMUMFORLEXLEVEL)                                           
00370800     OR (DISPLACEMENT < 0) THEN                                                     
00370900     CERROR(3);                                                                     
00371000  $POP OMIT                                                                         
00371100   IF (DISPLACEMENT >= STACKCELLS[LXLVL]) THEN BEGIN                                
00371200     STACKCELLS[LXLVL]:=DISPLACEMENT+1;                                             
00371300   END;                                                                             
00371400   IF CODETOG THEN BEGIN                                                            
00371500     FORMATADDRESS;                                                                 
00371600     REPLACE LBUF0+60 BY                                                            
00371700       (CASE OP.[1:2] OF ("VALC (","NAMC (","FTCH (","STOR (")),                    
00371800       LXLVL FOR 2 DIGITS,                                                          
00371900       ",",                                                                         
00372000       DISPLACEMENT FOR 5 DIGITS,                                                   
00372100       ")";                                                                         
00372200     WRITETOLINE;                                                                   
00372300   END;                                                                             
00372400   GENSYL(REAL(BOOLEAN(IF BOOLEAN(OP) THEN 4"4000" ELSE 0)                          
00372500     OR BOOLEAN(BITREVERSEDLEXLEVEL)                                                
00372600     OR BOOLEAN(DISPLACEMENT)).[15:8]);                                             
00372700   GENSYL(DISPLACEMENT.[7:8]);                                                      
00372800 END; % OF GENV                                                                     
00372900                                                                                    
00373000                                                                                    
00373100 PROCEDURE GENLIT(WORD);                                                            
00373200 %         ******                                                                   
00373300 VALUE WORD;                                                                        
00373400 REAL WORD;                                                                         
00373500 BEGIN                                                                              
00373600                                                                                    
00373700   BOOLEAN PROCEDURE REORGANIZE(WORD);                                              
00373800   VALUE WORD;                                                                      
00373900   REAL WORD;                                                                       
00374000   BEGIN                                                                            
00374100                                                                                    
00374200     PROCEDURE SIMPLESTRATEGY(WORD);                                                
00374300     % GENERATES ZERO, ONE, LT8 OR LT16                                             
00374400     VALUE WORD;                                                                    
00374500     REAL WORD;                                                                     
00374600     BEGIN                                                                          
00374700       IF (WORD IS 0) THEN BEGIN                                                    
00374800         GENOP(4"B0");           % ZERO                                             
00374900       END ELSE IF (WORD IS 1) THEN BEGIN                                           
00375000         GENOP(4"B1");           % ONE                                              
00375100       END ELSE IF (WORD.[47:40] IS 0) THEN BEGIN                                   
00375200         GENOP1(4"B2",WORD);     % LT8                                              
00375300       END ELSE BEGIN                                                               
00375400         GENLT16(WORD);          % LT16                                             
00375500       END;                                                                         
00375600     END; % OF SIMPLESTRATEGY                                                       
00375700                                                                                    
00375800     % TRIES SIMPLESTRATEGY, AND WITH  ONE EXTRA BIT ABOVE POSITION 15,             
00375900     %    ELSE TRIES COMPACT GROUP STRATEGY, ELSE GIVES UP.                         
00376000     REAL SHIFTWORD,TOPWORD;                                                        
00376100     INTEGER FIRSTBIT,LENGTH;                                                       
00376200     TOPWORD:=WORD.[47:32];                                                         
00376300     IF (TOPWORD IS 0) THEN BEGIN                                                   
00376400       SIMPLESTRATEGY(WORD);                                                        
00376500       REORGANIZE:=TRUE;                                                            
00376600     END ELSE IF (ONES(TOPWORD)=1) THEN BEGIN                                       
00376700       SIMPLESTRATEGY(WORD.[15:16]);                                                
00376800       GENOP1(BSET,FIRSTONE(WORD)-1);                                               
00376900       REORGANIZE:=TRUE;                                                            
00377000     END ELSE BEGIN                                                                 
00377100       FIRSTBIT:=FIRSTONE(WORD)-1;                                                  
00377200       SHIFTWORD:=WORD.[FIRSTBIT:48];                                               
00377300       IF (SHIFTWORD.[31:32] IS 0) THEN BEGIN                                       
00377400         LENGTH:=16;                                                                
00377500         WHILE NOT BOOLEAN(SHIFTWORD.[32:1]) DO BEGIN                               
00377600           SHIFTWORD:=SHIFTWORD.[0:48];                                             
00377700           LENGTH:=LENGTH-1;                                                        
00377800         END; % OF WHILE                                                            
00377900         SIMPLESTRATEGY(SHIFTWORD.[47:16]);                                         
00378000         GENOP2(ISOL,46+LENGTH-FIRSTBIT,48);                                        
00378100         REORGANIZE:=TRUE;                                                          
00378200       END ELSE BEGIN                                                               
00378300         REORGANIZE:=FALSE;                                                         
00378400       END;                                                                         
00378500     END; % OF IF ON TOPWORD                                                        
00378600   END; % OF REORGANIZE                                                             
00378700                                                                                    
00378800   % TRIES ON WORD, -(WORD), NOT(WORD), ELSE USES LT48                              
00378900   BOOLEAN SUCCESSFUL;                                                              
00379000                                                                                    
00379100   IF BOOLEAN(WORD.[46:1]) THEN BEGIN    % SIGN BIT                                 
00379200     SUCCESSFUL:=REORGANIZE(-WORD);                                                 
00379300     IF SUCCESSFUL THEN GENOP(4"8E");    % CHSN                                     
00379400   END ELSE BEGIN                                                                   
00379500     SUCCESSFUL:=REORGANIZE(WORD);                                                  
00379600   END;                                                                             
00379700   IF NOT SUCCESSFUL THEN BEGIN                                                     
00379800     SUCCESSFUL:=REORGANIZE(REAL(NOT BOOLEAN(WORD)));                               
00379900     IF SUCCESSFUL THEN GENOP(4"92");    % LNOT                                     
00380000   END;                                                                             
00380100   IF NOT SUCCESSFUL THEN BEGIN                                                     
00380200     GENLT48(4"BE",WORD);                % LT48                                     
00380300   END;                                                                             
00380400 END; % OF GENLIT                                                                   
00380500                                                                                    
00380600                                                                                    
00380700 PROCEDURE GENEDIT(SINGLE,OP,COUNT,CH1,CH2,CH3);                                    
00380800 %         *******                                                                  
00380900 VALUE SINGLE,OP,COUNT,CH1,CH2,CH3;                                                 
00381000 BOOLEAN SINGLE;                                                                    
00381100 INTEGER OP,COUNT,CH1,CH2,CH3;                                                      
00381200 BEGIN                                                                              
00381300   REAL EDITINFO;                                                                   
00381400   REAL VALUE ARRAY EDITTABLE(                                                      
00381500   %---------------------------------------------------------------------           
00381600   % FIRST FIELD IS PERMISSION MASK FOR                                             
00381700   %   (1) REPEAT COUNT, AND (2)&(3)&(4) EDIT CHARACTERS                            
00381800   % SECOND FIELD IS EDIT OPERATOR MNEMONIC                                         
00381900   %---------------------------------------------------------------------           
00382000     1"1100","MINS",1"1111","MFLT",1"1000","SFSC",1"1000","SRSC",                   
00382100     1"0000","RSTF",1"0110","ENDF",1"1000","MVNU",1"1000","MCHR",                   
00382200     1"0000","INOP",1"0110","INSG",1"1000","SFDC",1"1000","SRDC",                   
00382300     1"1100","INSU",1"1110","INSC",1"0000","ENDE");                                 
00382400                                                                                    
00382500   PROCEDURE TRYCHAR(CH,J);                                                         
00382600   VALUE CH,J;                                                                      
00382700   INTEGER CH,J;                                                                    
00382800   BEGIN                                                                            
00382900     IF BOOLEAN(J) THEN BEGIN                                                       
00383000       IF CODETOG THEN BEGIN                                                        
00383100         REPLACE H[0] BY CH.[7:48] FOR 2;                                           
00383200         REPLACE LBUF0 BY                                                           
00383300           " " FOR 60,                                                              
00383400           "=#",                                                                    
00383500           H[0] FOR 2 WITH HEXTOEBCDIC,                                             
00383600           "  ",                                                                    
00383700           """,                                                                     
00383800           CH.[7:48] FOR 1,                                                         
00383900           """;                                                                     
00384000         WRITETOLINE;                                                               
00384100       END;                                                                         
00384200  $SET OMIT = NOT DEBUG                                                             
00384300     END ELSE BEGIN                                                                 
00384400       IF (CH NEQ 0) THEN CERROR(6);                                                
00384500  $POP OMIT                                                                         
00384600     END;                                                                           
00384700   END; % OF TRYCHAR                                                                
00384800                                                                                    
00384900  $SET OMIT = NOT DEBUG                                                             
00385000   % IF BIT 9 IS SET, THE OPERATOR IS IN EDIT MODE                                  
00385100   IF (OP.[47:40] ISNT 2) THEN BEGIN                                                
00385200     CERROR(4);                                                                     
00385300   END                                                                              
00385400   ELSE                                                                             
00385500  $POP OMIT                                                                         
00385600   BEGIN                                                                            
00385700     OP:=OP.BYTEMASK;                                                               
00385800     EDITINFO:=EDITTABLE[(OP-4"D0")*2];                                             
00385900     IF CODETOG THEN BEGIN                                                          
00386000       FORMATADDRESS;                                                               
00386100       REPLACE LBUF0+60 BY                                                          
00386200         EDITTABLE[((OP-4"D0")*2)+1].[31:48] FOR 4;                                 
00386300       WRITETOLINE;                                                                 
00386400     END;                                                                           
00386500     GENSYL(OP);                                                                    
00386600     %                                                                              
00386700     IF (NOT SINGLE) AND BOOLEAN(EDITINFO.[3:1]) THEN BEGIN                         
00386800       IF CODETOG THEN BEGIN                                                        
00386900         REPLACE LBUF0+60 BY                                                        
00387000           "=",                                                                     
00387100           COUNT FOR 3 DIGITS;                                                      
00387200         WRITETOLINE;                                                               
00387300       END;                                                                         
00387400       GENSYL(COUNT.[7:8]);                                                         
00387500  $SET OMIT = NOT DEBUG                                                             
00387600     END ELSE BEGIN                                                                 
00387700       IF (COUNT NEQ 0) THEN CERROR(5);                                             
00387800  $POP OMIT                                                                         
00387900     END;                                                                           
00388000     TRYCHAR(CH1,EDITINFO.[2:1]);                                                   
00388100     TRYCHAR(CH2,EDITINFO.[1:1]);                                                   
00388200     TRYCHAR(CH3,EDITINFO.[0:1]);                                                   
00388300   END;                                                                             
00388400 END; % OF GENEDIT                                                                  
00388500                                                                                    
00388600                                                                                    
00388700 %***********************************************************************           
00388800 %                                                                                  
00388900 % COMPILER PACKAGE 2 VERSION 1.0  -CODE GENERATION-                                
00389000 %                                                                                  
00389100 % LABEL AND BRANCH PROCESSING ROUTINES                                             
00389200 %                                                                                  
00389300 % (C) COPYRIGHT  PROF A.H.J.SALE                                                   
00389400 %                DEPARTMENT OF INFORMATION SCIENCE                                 
00389500 %                UNIVERSITY OF TASMANIA                                            
00389600 %                BOX 252C G.P.O.  HOBART  TASMANIA 7001                            
00389700 %                                                                                  
00389800 % MOSTLY USER-INTERFACE ROUTINES                                                   
00389900 %   WILL NOT NEED USER-MODIFICATION                                                
00390000 %                                                                                  
00390100 %***********************************************************************           
00390200                                                                                    
00390300                                                                                    
00390400 INTEGER PROCEDURE MAKELABEL;                                                       
00390500 %                 *********                                                        
00390600 BEGIN                                                                              
00390700   INTEGER NEWINDEX;                                                                
00390800   LASTLABELALLOCATED:=*+1;                                                         
00390900   NEWINDEX:=LASTLABELALLOCATED+LABELBASE;                                          
00391000   IF (NEWINDEX > LABELTABLELIMIT) THEN CERROR(15);                                 
00391100   LABELTABLE[NEWINDEX]:=0;                                                         
00391200   MAKELABEL:=LASTLABELALLOCATED;                                                   
00391300 END; % OF MAKELABEL                                                                
00391400                                                                                    
00391500                                                                                    
00391600 PROCEDURE GENBR(OP,LAB);                                                           
00391700 %         *****                                                                    
00391800 VALUE OP,LAB;                                                                      
00391900 INTEGER OP,LAB;                                                                    
00392000 BEGIN                                                                              
00392100   REAL LABWORD,TEMP;                                                               
00392200  $SET OMIT = NOT DEBUG                                                             
00392300   IF (LAB <= 0) OR                                                                 
00392400      (LAB > LASTLABELALLOCATED) THEN                                               
00392500        CERROR(11);                                                                 
00392600  $POP OMIT                                                                         
00392700   IF CODETOG THEN BEGIN                                                            
00392800     FORMATADDRESS;                                                                 
00392900     REPLACE LBUF0+60 BY                                                            
00393000       (IF (OP=VEBR) THEN "VEBR" ELSE OPNAME[OP-4"80"].[31:48]) FOR 4,              
00393100       " (L",                                                                       
00393200       LAB FOR 4 DIGITS,                                                            
00393300       ")";                                                                         
00393400     WRITETOLINE;                                                                   
00393500   END;                                                                             
00393600   GENSYL(OP);                                                                      
00393700   LABWORD:=LABELTABLE[LAB+LABELBASE];                                              
00393800   IF BOOLEAN(LABWORD.[47:1]) THEN BEGIN                                            
00393900     % LABEL IS DEFINED                                                             
00394000     GENSYL(LABWORD.[35:8]);                                                        
00394100     GENSYL(LABWORD.[27:8]);                                                        
00394200   END ELSE BEGIN                                                                   
00394300     % LABEL IS NOT YET DEFINED                                                     
00394400     TEMP:=SEGWORDINDEX & SEGSYLINDEX [15:3];                                       
00394500     GENSYL(LABWORD.[15:8]);                                                        
00394600     GENSYL(LABWORD.[07:8]);                                                        
00394700     LABELTABLE[LAB+LABELBASE]:= * & TEMP [15:16];                                  
00394800   END;                                                                             
00394900 END; % OF GENBR                                                                    
00395000                                                                                    
00395100                                                                                    
00395200 REAL PROCEDURE ASKFORPCW(LAB);                                                     
00395300 %              *********                                                           
00395400 VALUE LAB;                                                                         
00395500 INTEGER LAB;                                                                       
00395600 BEGIN                                                                              
00395700  $SET OMIT = NOT DEBUG                                                             
00395800   IF (LAB<=0) OR (LAB>LASTLABELALLOCATED) THEN CERROR(11);                         
00395900  $POP OMIT                                                                         
00396000   ASKFORPCW:=LABELTABLE[LAB+LABELBASE];                                            
00396100 END; % OF ASKFORPCW                                                                
00396200                                                                                    
00396300                                                                                    
00396400 PROCEDURE GENHALFWORDADDRESS(LAB);                                                 
00396500 %         ******************                                                       
00396600 VALUE LAB;                                                                         
00396700 INTEGER LAB;                                                                       
00396800 BEGIN                                                                              
00396900   REAL LABWORD,TEMP;                                                               
00397000  $SET OMIT = NOT DEBUG                                                             
00397100   IF (LAB<=0) OR (LAB>LASTLABELALLOCATED) THEN CERROR(11);                         
00397200  $POP OMIT                                                                         
00397300   IF CODETOG THEN BEGIN                                                            
00397400     FORMATADDRESS;                                                                 
00397500     REPLACE LBUF0+60 BY                                                            
00397600       "LT16 (L",                                                                   
00397700       LAB FOR 4 DIGITS,                                                            
00397800       " TO HALFWORD)";                                                             
00397900     WRITETOLINE;                                                                   
00398000   END;                                                                             
00398100   GENSYL(4"B3");                                                                   
00398200   LABWORD:=LABELTABLE[LAB+LABELBASE];                                              
00398300   IF BOOLEAN(LABWORD.[47:1]) THEN BEGIN                                            
00398400     % LABEL IS DEFINED                                                             
00398500     IF (LABWORD.[35:3]=0) OR (LABWORD.[35:3]=3) THEN CERROR(12);                   
00398600     TEMP:=(LABWORD.[32:14]) & LABWORD [0:33:1];                                    
00398700     GENSYL(TEMP.[15:8]);                                                           
00398800     GENSYL(TEMP.[07:8]);                                                           
00398900   END ELSE BEGIN                                                                   
00399000     % LABEL IS NOT YET DEFINED                                                     
00399100     TEMP:=SEGWORDINDEX & SEGSYLINDEX [15:3];                                       
00399200     GENSYL(LABWORD.[31:8]);                                                        
00399300     GENSYL(LABWORD.[23:8]);                                                        
00399400     LABELTABLE[LAB+LABELBASE]:= * & TEMP [31:16];                                  
00399500   END;                                                                             
00399600 END; % OF GENHALFWORDADDRESS                                                       
00399700                                                                                    
00399800                                                                                    
00399900 PROCEDURE GENLABEL(LAB);                                                           
00400000 %         ********                                                                 
00400100 VALUE LAB;                                                                         
00400200 INTEGER LAB;                                                                       
00400300 BEGIN                                                                              
00400400                                                                                    
00400500   PROCEDURE PLACELABEL(PREFIX,ADDRESS,NEWVAL);                                     
00400600   %                        IN      IO     IN                                       
00400700   VALUE PREFIX,NEWVAL;                                                             
00400800   INTEGER ADDRESS,NEWVAL;                                                          
00400900   REAL PREFIX;                                                                     
00401000   BEGIN                                                                            
00401100     POINTER P,Q;                                                                   
00401200     IF HEXCODETOG THEN BEGIN                                                       
00401300       REPLACE H[0] BY SEGNUMBER.[11:48] FOR 3,                                     
00401400          ((ADDRESS.[12:13])-SEGMENTBASE).[15:48] FOR 4;                            
00401500       REPLACE LBUF0 BY                                                             
00401600         PREFIX.[31:48] FOR 4,                                                      
00401700         " PATCH AT ",                                                              
00401800         H[0] FOR 3 WITH HEXTOEBCDIC,                                               
00401900         ":",                                                                       
00402000         H[3] FOR 4 WITH HEXTOEBCDIC,                                               
00402100         ":",                                                                       
00402200         (ADDRESS.[15:3]) FOR 1 DIGITS;                                             
00402300       WRITETOLINE;                                                                 
00402400     END;                                                                           
00402500     P:=POINTER(SEGBUF[ADDRESS.[12:13]])+(ADDRESS.[15:3]);                          
00402600     Q:=POINTER(T[0]);                                                              
00402700     REPLACE Q BY P FOR 2;                                                          
00402800     ADDRESS:=T[0].[47:16];                                                         
00402900     T[0].[47:16]:=NEWVAL;                                                          
00403000     REPLACE P BY Q FOR 2;                                                          
00403100   END; % OF PLACELABEL                                                             
00403200                                                                                    
00403300   REAL LABWORD,NEW,PTR,TEMP;                                                       
00403400   IF CODETOG THEN BEGIN                                                            
00403500     FORMATADDRESS;                                                                 
00403600     REPLACE LBUF0+50 BY                                                            
00403700       "    [L",                                                                    
00403800       LAB FOR 4 DIGITS,                                                            
00403900       "]";                                                                         
00404000     WRITETOLINE;                                                                   
00404100   END;                                                                             
00404200   LABWORD:=LABELTABLE[LAB+LABELBASE];                                              
00404300   IF BOOLEAN(LABWORD.[47:1]) THEN BEGIN                                            
00404400  $SET OMIT = NOT DEBUG                                                             
00404500     % ALREADY DEFINED IS ERROR                                                     
00404600     CERROR(14);                                                                    
00404700  $POP OMIT                                                                         
00404800   END ELSE BEGIN                                                                   
00404900     NEW:=SEGNUMBER                                                                 
00405000         & LEXLEVEL [18:5]                                                          
00405100         & 1 [13:1]                                                                 
00405200         & (SEGWORDINDEX-SEGMENTBASE) [32:13]                                       
00405300         & SEGSYLINDEX [35:3]                                                       
00405400         & 1 [47:1];                                                                
00405500     % FILL IN BRANCH FIELDS                                                        
00405600     PTR:=LABWORD.[15:16];                                                          
00405700     WHILE (PTR NEQ 0) DO BEGIN                                                     
00405800       PLACELABEL(">>BR",PTR,NEW.[35:16]);                                          
00405900     END;                                                                           
00406000     % FILL IN HALF-WORD LITERAL ADDRESSES                                          
00406100     PTR:=LABWORD.[31:16];                                                          
00406200     WHILE (PTR NEQ 0) DO BEGIN                                                     
00406300       IF (SEGSYLINDEX NEQ 0) AND (SEGSYLINDEX NEQ 3) THEN CERROR(13);              
00406400       PLACELABEL("LT16",PTR,(NEW.[32:14]) & NEW [0:33:1]);                         
00406500     END;                                                                           
00406600     LABELTABLE[LAB+LABELBASE]:= NEW;                                               
00406700   END;                                                                             
00406800 END; % OF GENLABEL                                                                 
00406900                                                                                    
00407000                                                                                    
00407100 %***********************************************************************           
00407200 %                                                                                  
00407300 % COMPILER PACKAGE 2 VERSION 1.0  -CODE GENERATION-                                
00407400 %                                                                                  
00407500 % SEGMENT START/FINISH ROUTINES                                                    
00407600 %                                                                                  
00407700 % (C) COPYRIGHT  PROF A.H.J.SALE                                                   
00407800 %                DEPARTMENT OF INFORMATION SCIENCE                                 
00407900 %                UNIVERSITY OF TASMANIA                                            
00408000 %                BOX 252C G.P.O.  HOBART  TASMANIA 7001                            
00408100 %                                                                                  
00408200 % MOSTLY USER-INTERFACE ROUTINES                                                   
00408300 %   WILL NOT NEED USER-MODIFICATION                                                
00408400 %                                                                                  
00408500 %***********************************************************************           
00408600                                                                                    
00408700                                                                                    
00408800 INTEGER PROCEDURE MAKED1SLOT;                                                      
00408900 %                 **********                                                       
00409000 BEGIN                                                                              
00409100   IF LASTD1SLOTALLOCATED >= D1STACKLIMIT THEN BEGIN                                
00409200     CERROR(16);                                                                    
00409300   END;                                                                             
00409400   MAKED1SLOT:=(LASTD1SLOTALLOCATED:=LASTD1SLOTALLOCATED+1);                        
00409500 END;                                                                               
00409600                                                                                    
00409700                                                                                    
00409800 PROCEDURE BEGINNEWSEGMENT(STYPE);                                                  
00409900 %         ***************                                                          
00410000 VALUE STYPE;                                                                       
00410100 INTEGER STYPE;                                                                     
00410200 %-----------------------------------------------------------------------           
00410300 %                                                                                  
00410400 % PUSH STATE DOWN ONTO SEGBUF AND LABELTABLE                                       
00410500 %   AND SET UP FOR NEW SEGMENT TO BE ASSEMBLED                                     
00410600 %                                                                                  
00410700 %-----------------------------------------------------------------------           
00410800 BEGIN                                                                              
00410900   REAL DESCRIPTOR;                                                                 
00411000                                                                                    
00411100   %---------------------------------------------------------------------           
00411200   %                                                                                
00411300   % PUSH DOWN STATE DATA INTO SEGBUF AND SET ANEW                                  
00411400   %                                                                                
00411500   %---------------------------------------------------------------------           
00411600                                                                                    
00411700   SEGBUF[SEGWORDINDEX+1] :=                                                        
00411800         SEGWORDINDEX                                                               
00411900         & SEGSYLINDEX [15:3]                                                       
00412000         & SEGMENTBASE [28:13]                                                      
00412100         & SEGTYPE [31:3]                                                           
00412200         & SEGNUMBER [44:13];                                                       
00412300                                                                                    
00412400   SEGWORDINDEX:=SEGMENTBASE:=SEGWORDINDEX+2;                                       
00412500   SEGSYLINDEX:=0;                                                                  
00412600   SEGTYPE:= STYPE;                                                                 
00412700   IF (SEGTYPE NEQ INFOSEGTYPE) THEN BEGIN                                          
00412800     SEGNUMBER:= MAKED1SLOT;                                                        
00412900     DESCRIPTOR:=(SEGMENTBASE.[19:20])     % ADDRESS IN SEGBUF                      
00413000                 & 1 [47:1];               % PRESENT (IN SEGBUF) BIT                
00413100   END ELSE BEGIN                                                                   
00413200     SEGNUMBER:=0;                                                                  
00413300   END;                                                                             
00413400                                                                                    
00413500   %---------------------------------------------------------------------           
00413600   %                                                                                
00413700   % SET D1 ENTRY FOR NEW SEGMENT, ALSO LABELS IF CODE SEGMENT                      
00413800   %                                                                                
00413900   %---------------------------------------------------------------------           
00414000                                                                                    
00414100   CASE SEGTYPE OF BEGIN                                                            
00414200                                                                                    
00414300   CODESEGTYPE:                                                                     
00414400         D1STACKTAGS[SEGNUMBER]:=3;                                                 
00414500         D1STACK[SEGNUMBER]:=DESCRIPTOR;                                            
00414600         LABELTABLE[LABELBASE+LASTLABELALLOCATED+1]:=                               
00414700                 LABELBASE & LASTLABELALLOCATED [31:16];                            
00414800         LABELBASE:=LABELBASE+LASTLABELALLOCATED+1;                                 
00414900         LASTLABELALLOCATED:=0;                                                     
00415000         LINEINFOBEGINSEGMENT;                                                      
00415100         GENSYL(4"FF");                                                             
00415200                                                                                    
00415300   WORDSEGTYPE:                                                                     
00415400         D1STACKTAGS[SEGNUMBER]:=5;                                                 
00415500         D1STACK[SEGNUMBER]:= DESCRIPTOR & 1 [43:1];     % READ-ONLY                
00415600                                                                                    
00415700   DOUBLESEGTYPE:                                                                   
00415800         D1STACKTAGS[SEGNUMBER]:= 5;                                                
00415900         D1STACK[SEGNUMBER]:= DESCRIPTOR & 1 [43:1]      % READ-ONLY                
00416000                                         & 1 [42:3];     % DOUBLE                   
00416100                                                                                    
00416200   INFOSEGTYPE:                                                                     
00416300         ;                                                                          
00416400   END; % OF CASE                                                                   
00416500   IF NAMESTOG OR CODETOG THEN BEGIN                                                
00416600     REPLACE H[0] BY                                                                
00416700       SEGNUMBER.[11:48] FOR 3;                                                     
00416800     REPLACE LBUF0+60 BY                                                            
00416900       "SEGMENT ",                                                                  
00417000       H[0] FOR 3 WITH HEXTOEBCDIC,                                                 
00417100       " CONTAINS ",                                                                
00417200       (CASE SEGTYPE OF ("CODE  ","DATA  ","DOUBLE","INFO  "));                     
00417300     WRITETOLINE;                                                                   
00417400   END;                                                                             
00417500 END; % OF BEGIN NEW SEGMENT                                                        
00417600                                                                                    
00417700                                                                                    
00417800 PROCEDURE CLOSESEGMENT;                                                            
00417900 %         ************                                                             
00418000 %-----------------------------------------------------------------------           
00418100 %                                                                                  
00418200 % CLOSE OFF SEGMENT AND WRITE TO CODE FILE                                         
00418300 %   THEN POP DATA UP FROM SAVED POSITIONS                                          
00418400 %                                                                                  
00418500 %-----------------------------------------------------------------------           
00418600 BEGIN                                                                              
00418700   INTEGER LENGTH,J,COREESTIMATE,STACKESTIMATE;                                     
00418800   REAL STATE;                                                                      
00418900                                                                                    
00419000   %---------------------------------------------------------------------           
00419100   %                                                                                
00419200   % PAD OUT TO APPROPRIATE BOUNDARY IF NEEDED                                      
00419300   %                                                                                
00419400   %---------------------------------------------------------------------           
00419500                                                                                    
00419600   CASE SEGTYPE OF BEGIN                                                            
00419700                                                                                    
00419800   CODESEGTYPE:                                                                     
00419900         GENSYL(4"FF");                                                             
00420000         WORDBOUNDARY;                                                              
00420100         % CHECK LABELS ALL SITED                                                   
00420200         IF CODETOG THEN BEGIN                                                      
00420300           FOR J:=(LABELBASE+1) UPTO LASTLABELALLOCATED DO BEGIN                    
00420400             IF NOT BOOLEAN(LABELTABLE[J].[47:1]) THEN BEGIN                        
00420500               REPLACE LBUF0+54 BY                                                  
00420600                 ">>>>>>LABEL L",                                                   
00420700                 (J-LABELBASE) FOR 4 DIGITS,                                        
00420800                 " IS NOT SITED";                                                   
00420900               WRITETOLINE;                                                         
00421000             END; % OF IF                                                           
00421100           END; % OF FOR                                                            
00421200         END; % OF IF                                                               
00421300                                                                                    
00421400   WORDSEGTYPE:                                                                     
00421500         WHILE SEGSYLINDEX NEQ 0 DO BEGIN                                           
00421600           GENSYL(0);                                                               
00421700         END;                                                                       
00421800                                                                                    
00421900   DOUBLESEGTYPE:                                                                   
00422000         WHILE SEGSYLINDEX NEQ 0 DO BEGIN                                           
00422100           GENSYL(0);                                                               
00422200         END;                                                                       
00422300         IF ((SEGWORDINDEX MOD 2) NEQ 0) THEN BEGIN                                 
00422400           GENWORD(0);                                                              
00422500         END;                                                                       
00422600                                                                                    
00422700   INFOSEGTYPE:                                                                     
00422800         ;                                                                          
00422900   END; % OF CASE                                                                   
00423000                                                                                    
00423100   %---------------------------------------------------------------------           
00423200   %                                                                                
00423300   % PUT THE SEGMENT OUT TO THE CODE FILE                                           
00423400   %                                                                                
00423500   %---------------------------------------------------------------------           
00423600                                                                                    
00423700   LENGTH:= SEGWORDINDEX-SEGMENTBASE;                                               
00423800   IF NAMESTOG OR CODETOG THEN BEGIN                                                
00423900     REPLACE H[0] BY                                                                
00424000       SEGNUMBER.[11:48] FOR 3;                                                     
00424100     REPLACE LBUF0+60 BY                                                            
00424200       "SEGMENT ",                                                                  
00424300       H[0] FOR 3 WITH HEXTOEBCDIC,                                                 
00424400       " LENGTH = ",                                                                
00424500       LENGTH FOR 4 DIGITS,                                                         
00424600       " WORDS";                                                                    
00424700     WRITETOLINE;                                                                   
00424800   END;                                                                             
00424900                                                                                    
00425000   % WRITE SEGMENT TO CODE FILE                                                     
00425100   WRITESEGMENT(SEGBUF,SEGMENTBASE,LENGTH,STARTSEG);                                
00425200                                                                                    
00425300   %---------------------------------------------------------------------           
00425400   %                                                                                
00425500   % MODIFY THE SEGMENT DESCRIPTOR IN D1 STACK (SEG DICT)                           
00425600   %                                                                                
00425700   %---------------------------------------------------------------------           
00425800                                                                                    
00425900   IF (SEGTYPE NEQ INFOSEGTYPE) THEN BEGIN                                          
00426000     D1STACK[SEGNUMBER]:=                                                           
00426100           *                                                                        
00426200           & LENGTH [39:20]                                                         
00426300           & STARTSEG [19:20]                                                       
00426400           & 0 [47:1];                                                              
00426500     %SET MCP VALUE ARRAY BIT                                                       
00426600     IF (SEGTYPE NEQ CODESEGTYPE) THEN BEGIN                                        
00426700       D1STACK[SEGNUMBER]:= * & 1 [19:2];                                           
00426800     END;                                                                           
00426900                                                                                    
00427000     % ACCUMULATE SIZE TOTALS                                                       
00427100     IF (SEGTYPE = CODESEGTYPE) THEN BEGIN                                          
00427200       CODESIZE:=CODESIZE+LENGTH;                                                   
00427300     END ELSE BEGIN                                                                 
00427400       VALUEARRAYSIZE:=VALUEARRAYSIZE+LENGTH;                                       
00427500     END;                                                                           
00427600     NOOFSEGMENTS[SEGTYPE]:=*+1;                                                    
00427700                                                                                    
00427800   END;                                                                             
00427900   %---------------------------------------------------------------------           
00428000   %                                                                                
00428100   % POP THE STATE INFORMATION                                                      
00428200   %                                                                                
00428300   %---------------------------------------------------------------------           
00428400                                                                                    
00428500   % CLEAN UP LABEL TABLE IF OLD WAS A CODE SEGMENT                                 
00428600   IF SEGTYPE = CODESEGTYPE THEN BEGIN                                              
00428700     STATE:=LABELTABLE[LABELBASE];                                                  
00428800     LASTLABELALLOCATED:= STATE .[31:16];                                           
00428900     LABELBASE:=STATE.[15:16];                                                      
00429000   END;                                                                             
00429100   % CLEAN UP THE LINEINFO IF WAS A CODE SEGMENT                                    
00429200   LINEINFOCLOSESEGMENT;                                                            
00429300                                                                                    
00429400   % CLEAN UP THE SEGMENT BUFFER AND ITS STATE                                      
00429500   STATE:=SEGBUF[SEGMENTBASE-1];                                                    
00429600   SEGWORDINDEX:=STATE.[12:13];                                                     
00429700   SEGSYLINDEX:=STATE.[15:3];                                                       
00429800   SEGMENTBASE:=STATE.[28:13];                                                      
00429900   SEGTYPE:=STATE.[31:3];                                                           
00430000   SEGNUMBER:=STATE.[44:13];                                                        
00430100                                                                                    
00430200 END; % OF CLOSE SEGMENT                                                            
00430300                                                                                    
00430400 %END OF SEGMENT-HANDLING************************************************           
00430500 %***********************************************************************           
00430600 %                                                                                  
00430700 % COMPILER PACKAGE 2 VERSION 1.0  -CODE GENERATION-                                
00430800 %                                                                                  
00430900 % PROGRAM CONTROL ROUTINES                                                         
00431000 %                                                                                  
00431100 % (C) COPYRIGHT  PROF A.H.J.SALE                                                   
00431200 %                DEPARTMENT OF INFORMATION SCIENCE                                 
00431300 %                UNIVERSITY OF TASMANIA                                            
00431400 %                BOX 252C G.P.O.  HOBART  TASMANIA 7001                            
00431500 %                                                                                  
00431600 % MOSTLY USER-INTERFACE ROUTINES                                                   
00431700 %   WILL NOT NEED USER-MODIFICATION                                                
00431800 %                                                                                  
00431900 %***********************************************************************           
00432000                                                                                    
00432100                                                                                    
00432200 PROCEDURE OPENCODEFILE;                                                            
00432300 %         ************                                                             
00432400 BEGIN                                                                              
00432500                                                                                    
00432600                                                                                    
00432700   %---------------------------------------------------------------------           
00432800   %                                                                                
00432900   % SET UP SEGMENT STATE, LABEL STATE, D1STACK STATE                               
00433000   %                                                                                
00433100   %---------------------------------------------------------------------           
00433200                                                                                    
00433300   SEGTYPE:=0;                                                                      
00433400   SEGMENTBASE:=0;                                                                  
00433500   SEGSYLINDEX:=SEGWORDINDEX:=0;                                                    
00433600                                                                                    
00433700   LASTLABELALLOCATED:= LABELBASE:= 0;                                              
00433800                                                                                    
00433900   LASTD1SLOTALLOCATED:=2;                                                          
00434000   D1STACK[0]:=0;                                                                   
00434100   D1STACK[1]:=0;                                                                   
00434200   D1STACK[2]:=4"00020000A003";                                                     
00434300   D1STACKTAGS[0]:=0;                                                               
00434400   D1STACKTAGS[1]:=0;                                                               
00434500   D1STACKTAGS[2]:=7;                                                               
00434600   LEXLEVEL:=2;                                                                     
00434700                                                                                    
00434800   %---------------------------------------------------------------------           
00434900   %                                                                                
00435000   %  MISC. INITIALIZATIONS                                                         
00435100   %                                                                                
00435200   %---------------------------------------------------------------------           
00435300                                                                                    
00435400   CODE.MAXRECSIZE := 30;                                                           
00435500   CODE.UNITS := 0;                                                                 
00435600   CODE.AREASIZE := CHUNK;                                                          
00435700   REPLACE POINTER(CODEBUF) BY " " FOR 30 WORDS;                                    
00435800   WRITE(CODE,30,CODEBUF[*]);                                                       
00435900   CODE.FILEKIND:=VALUE(DATA);                                                      
00436000   DISKSECTOR:=1;                                                                   
00436100                                                                                    
00436200   REPLACE POINTER(STACKCELLS) BY 0 FOR 32 WORDS;                                   
00436300   REPLACE POINTER(ARRAYCELLS) BY 0 FOR 32 WORDS;                                   
00436400   REPLACE POINTER(NOOFSEGMENTS) BY 0 FOR 3 WORDS;                                  
00436500   CODESIZE:=0;                                                                     
00436600   VALUEARRAYSIZE:=0;                                                               
00436700                                                                                    
00436800   LINEINFOINITIALIZE;                                                              
00436900                                                                                    
00437000   MYSELF.TASKVALUE:=0;                                                             
00437100                                                                                    
00437200   BEGINNEWSEGMENT(0);                                                              
00437300                                                                                    
00437400 END; % OF OPEN CODE FILE                                                           
00437500                                                                                    
00437600 INTEGER PROCEDURE COMPBIND(SHEET);                                                 
00437700 %                 ********                                                         
00437800 REAL ARRAY SHEET[*];                                                               
00437900 BEGIN                                                                              
00438000 %   THIS PROCEDURE SHOULD BE REPLACEMENT BOUND BY THE REAL                         
00438100 %   SYSTEM/COMPBIND - IF NOT THEN THE CODEFILE WILL BE LOCKED                      
00438200 %   AND A WARNING ISSUED.                                                          
00438300   ERROR(1020);                                                                     
00438400 END;                                                                               
00438500                                                                                    
00438600                                                                                    
00438700                                                                                    
00438800 PROCEDURE CLOSECODEFILE(DISASTERSIGNAL);                                           
00438900 %         *************                                                            
00439000 VALUE DISASTERSIGNAL;                                                              
00439100 BOOLEAN DISASTERSIGNAL;                                                            
00439200 BEGIN                                                                              
00439300   INTEGER J,STARTSEG,D1ENTRIES,BLOCK,STACKESTIMATE,COREESTIMATE,                   
00439400           ARRAYSIZE,STACKSIZE;                                                     
00439500                                                                                    
00439600   POINTER PCODE,PTEMP,PBUF,PBUF2;                                                  
00439700                                                                                    
00439800   FORMAT                                                                           
00439900     NOFORMAT("NO OF:    ",2(X5,I10)),                                              
00440000     SZFORMAT("SIZE:     ",5(X5,I10));                                              
00440100                                                                                    
00440200   REAL ARRAY LINEBUFFER[0:21];                                                     
00440300                                                                                    
00440400   DEFINE CODELOCATION(DSKSECTOR,LNGTH)                                             
00440500     =((DSKSECTOR.[19:20]) & (LNGTH) [39:20])#;                                     
00440600                                                                                    
00440700   PROCEDURE WRITEBUF;                                                              
00440800   BEGIN                                                                            
00440900     WRITE(LINE,22,LINEBUFFER[*]);                                                  
00441000     REPLACE PBUF BY "      " FOR 22 WORDS;                                         
00441100   END; % OF WRITE BUF                                                              
00441200                                                                                    
00441300   %=====================================================================           
00441400   PBUF:=POINTER(LINEBUFFER[0]);                                                    
00441500                                                                                    
00441600   IF NOT DISASTERSIGNAL THEN CLOSESEGMENT;                                         
00441700                                                                                    
00441800  $SET OMIT = NOT DEBUG                                                             
00441900   IF (SEGMENTBASE NEQ 0) THEN CERROR(18);                                          
00442000  $POP OMIT                                                                         
00442100   IF (NOOFERRORS > 0) THEN BEGIN                                                   
00442200     CLOSE(CODE,PURGE);                                                             
00442300     MYSELF.TASKVALUE:=1;                                                           
00442400     PASCALCOMPILER:=1;                                                             
00442500   END ELSE BEGIN                                                                   
00442600                                                                                    
00442700     % EMPTY LINE INFO                                                              
00442800     LINEINFOWRAPUP;                                                                
00442900                                                                                    
00443000     %-------------------------------------------------------------------           
00443100     %                                                                              
00443200     % WRITE SEGMENT DICTIONARY (D1 STACK)                                          
00443300     %                                                                              
00443400     %-------------------------------------------------------------------           
00443500                                                                                    
00443600     PCODE:=POINTER(SEGBUF);                                                        
00443700     PTEMP:=POINTER(T)+4;                                                           
00443800     IF HEXCODETOG THEN BEGIN                                                       
00443900       REPLACE PBUF BY "D1 STACK:",                                                 
00444000         " " FOR 123;                                                               
00444100       WRITEBUF;                                                                    
00444200     END;                                                                           
00444300     FOR J:=0 UPTO LASTD1SLOTALLOCATED DO BEGIN                                     
00444400       T[0]:=D1STACKTAGS[J].[39:48];                                                
00444500       T[1]:=D1STACK[J];                                                            
00444600       REPLACE PCODE:PCODE BY PTEMP FOR 8;                                          
00444700       IF HEXCODETOG THEN BEGIN                                                     
00444800         REPLACE H[0] BY T[0].[15:48] FOR 4,                                        
00444900           T[1].[47:48] FOR 12;                                                     
00445000         REPLACE PBUF+((J MOD 6)*20+1) BY H[0] FOR 16 WITH HEXTOEBCDIC;             
00445100         IF((J+1) MOD 6 =0) THEN WRITEBUF;                                          
00445200       END;                                                                         
00445300     END;                                                                           
00445400     IF HEXCODETOG THEN WRITEBUF;                                                   
00445500     D1ENTRIES:=LASTD1SLOTALLOCATED+1;                                              
00445600     WRITESEGMENT(SEGBUF,0,((D1ENTRIES*8)+5) DIV 6,STARTSEG);                       
00445700     % LOCATION AND LENGTH OF D1 STACK                                              
00445800     SEGZERO[18]:=CODELOCATION(STARTSEG,D1ENTRIES);                                 
00445900                                                                                    
00446000     %-------------------------------------------------------------------           
00446100     %                                                                              
00446200     % WRITE THE PPB/FPB PASSED IN BY THE SEGZERO PARAMETER                         
00446300     %                                                                              
00446400     %-------------------------------------------------------------------           
00446500                                                                                    
00446600     BLOCK:=SEGZERO[0].[46:47];                                                     
00446700     IF (BLOCK NEQ 0) THEN BEGIN                                                    
00446800       J:=SEGZERO[BLOCK];                                                           
00446900       REPLACE POINTER(SEGBUF) BY POINTER(SEGZERO[BLOCK]) FOR J WORDS;              
00447000       WRITESEGMENT(SEGBUF,0,J,STARTSEG);                                           
00447100       SEGZERO[12]:=CODELOCATION(STARTSEG,J);                                       
00447200     END;                                                                           
00447300                                                                                    
00447400     %-------------------------------------------------------------------           
00447500     %                                                                              
00447600     % CREATE AND WRITE SECTOR ZERO TO CODE FILE                                    
00447700     %                                                                              
00447800     %-------------------------------------------------------------------           
00447900                                                                                    
00448000     REPLACE POINTER(SEGBUF) BY POINTER(SEGZERO) FOR 30 WORDS;                      
00448100     % ZERO OUT THE PPB/PFB & CANDE WORD                                            
00448200     SEGBUF[0]:=0;                                                                  
00448300     % POINTER TO D1 STACK ENTRY WHICH IS STARTING PCW                              
00448400     SEGBUF[2]:=2;                                                                  
00448500     % SIZE OF CODE FILE                                                            
00448600     SEGBUF[3]:=DISKSECTOR;                                                         
00448700     % DATE                                                                         
00448800     SEGBUF[4]:=TIME(5);                                                            
00448900     % TIME                                                                         
00449000     SEGBUF[5]:=TIME(11);                                                           
00449100     % NO OF MAIN PROGRAM PARAMETERS                                                
00449200     %   HIGH BIT = EXECUTABLE AS A UNIT                                            
00449300     SEGBUF[6]:=PARAMCOUNT & 0 [47:1];                                              
00449400     % PROGRAM DESCRIPTION                                                          
00449500     SEGBUF[16] := BLDPROGRAMDESCRIPTION;                                           
00449600     % CORE ESTIMATE IS REQUIRED                                                    
00449700     STACKESTIMATE:=0;                                                              
00449800     ARRAYSIZE:=0;                                                                  
00449900     FOR J:=2 UPTO 31 DO BEGIN                                                      
00450000       STACKESTIMATE:=STACKESTIMATE+STACKCELLS[J];                                  
00450100       ARRAYSIZE:=ARRAYSIZE+ARRAYCELLS[J];                                          
00450200     END;                                                                           
00450300     STACKSIZE:=512;                      % USE THIS AS STANDARD SIZE               
00450400     COREESTIMATE:=STACKSIZE + D1ENTRIES + (CODESIZE * 0.5)                         
00450500       +((VALUEARRAYSIZE + ARRAYSIZE) * 0.5);                                       
00450600     IF (SEGBUF[7] = 0) THEN BEGIN                                                  
00450700       SEGBUF[7]:=COREESTIMATE;                                                     
00450800     END;                                                                           
00450900     % COMPILER INFO WORD                                                           
00451000     SEGBUF[8]:=                                                                    
00451100         CAPABILITIES                                                               
00451200         & LANGUAGE [31:8]                                                          
00451300         & (COMPILETIME(21)) [7:8]                                                  
00451400         & (COMPILETIME(20) MOD 10) [15:8]                                          
00451500         & (COMPILETIME(20) DIV 10) [23:8];                                         
00451600     % DEFAULT STACK LIMIT                                                          
00451700     IF (SEGBUF[15] = 0) THEN SEGBUF[15]:=STACKSIZE;                                
00451800                                                                                    
00451900     % THEN WRITE SEGMENT ZERO TO CODE FILE                                         
00452000     REWIND(CODE);                                                                  
00452100     WRITE(CODE[0],30,SEGBUF[*]);                                                   
00452200 %   CODE.FILEKIND:=VALUE(ALGOLCODE); %<<<<<<<<<<<<<<<<<<<<<                        
00452300   %*********************************************************************           
00452400   %                                                                                
00452500   % THIS IS REQUIRED IF THIS IS TO BE A REAL COMPILER                              
00452600   %                                                                                
00452700   %*********************************************************************           
00452800     CODE.FILEKIND := VALUE( ALGOLCODE );                                           
00452900   %*********************************************************************           
00453000     IF AUTOBINDTOG THEN BEGIN                                                      
00453100       REPLACE BINDCONTROL[CBINDCHARS] BY "END;" FOR 4;                             
00453200       REWIND(CODE);                                                                
00453300       ABFILECONTROL := 0;   %SINGLE HOST                                           
00453400       IF (COMPBIND(SEGBUF) = 0) THEN BEGIN                                         
00453500         LOCK(CODE,CRUNCH);                                                         
00453600         MYSELF.TASKVALUE:=0;                                                       
00453700         PASCALCOMPILER:=0;                                                         
00453800       END ELSE BEGIN                                                               
00453900         CLOSE(CODE,PURGE);                                                         
00454000         MYSELF.TASKVALUE := 1;                                                     
00454100         PASCALCOMPILER := 1;                                                       
00454200       END;                                                                         
00454300     END ELSE BEGIN                                                                 
00454400       LOCK(CODE,CRUNCH);                                                           
00454500       MYSELF.TASKVALUE:=0;                                                         
00454600       PASCALCOMPILER:=0;                                                           
00454700     END;                                                                           
00454800                                                                                    
00454900   END; % OF FINALIZING CODE FILE                                                   
00455000                                                                                    
00455100   %---------------------------------------------------------------------           
00455200   %                                                                                
00455300   % WRITE COMPILATION SUMMARY                                                      
00455400   %                                                                                
00455500   %---------------------------------------------------------------------           
00455600                                                                                    
00455700   IF HEADINGPRINTED THEN                                                           
00455800   BEGIN                                                                            
00455900     REPLACE PBUF BY                                                                
00456000       "=" FOR 51,                                                                  
00456100       "COMPILATION SUMMARY" FOR 19,                                                
00456200       "=" FOR 50,                                                                  
00456300       " " FOR 12;                                                                  
00456400     WRITEBUF;                                                                      
00456500     REPLACE PBUF BY                                                                
00456600       "PROGRAM SOURCE FILE TITLE: ",                                               
00456700       CARD.TITLE;                                                                  
00456800     WRITEBUF;                                                                      
00456900     IF NEWTOG THEN BEGIN                                                           
00457000       REPLACE PBUF BY                                                              
00457100         "PROGRAM NEWTAPE FILE TITLE: ",                                            
00457200         NEWTAPE.TITLE;                                                             
00457300       WRITEBUF;                                                                    
00457400     END;                                                                           
00457500     REPLACE PBUF2:PBUF BY                                                          
00457600       "PROGRAM CODE FILE TITLE: ";                                                 
00457700     REPLACE PBUF2 BY                                                               
00457800       CODE.TITLE;                                                                  
00457900     WRITEBUF;                                                                      
00458000     IF (NOOFERRORS > 0) THEN BEGIN                                                 
00458100       REPLACE PBUF BY                                                              
00458200         "PROGRAM CAUSED ",                                                         
00458300         NOOFERRORS FOR DIGITSIN(NOOFERRORS) DIGITS,                                
00458400         " TRANSLATION ERRORS DUE TO SYNTACTIC/SEMANTIC FLAWS";                     
00458500     END ELSE BEGIN                                                                 
00458600       REPLACE PBUF BY "NO ERRORS FOUND BY COMPILER";                               
00458700     END;                                                                           
00458800     WRITEBUF; WRITEBUF;                                                            
00458900     REPLACE PBUF BY                                                                
00459000       "          ",                                                                
00459100       "  CODE SEGMENTS",                                                           
00459200       "   VALUE ARRAYS",                                                           
00459300       "     EST. STACK",                                                           
00459400       "    EST. MEMORY",                                                           
00459500       "   DISK SECTORS";                                                           
00459600     WRITEBUF;                                                                      
00459700     WRITE(LINE,NOFORMAT,                                                           
00459800       NOOFSEGMENTS[0],(NOOFSEGMENTS[1]+NOOFSEGMENTS[2]) );                         
00459900     WRITE(LINE,SZFORMAT,                                                           
00460000       CODESIZE,VALUEARRAYSIZE,STACKESTIMATE,COREESTIMATE,DISKSECTOR);              
00460100     REPLACE PBUF BY "======" FOR 20 WORDS;                                         
00460200     WRITEBUF;                                                                      
00460300   END;                                                                             
00460400                                                                                    
00460500 END; % OF CLOSE CODE FILE                                                          
00460600                                                                                    
00460700 %END OF COMPILER/PACKAGE2/PROGRAM HANDLING  ****************************           
00460800   %                                                                                
00460900                                                                                    
00461000                                                                                    
00461100 %=======================================================================           
00461200 % ERROR HANDLERS                                                                   
00461300 %=======================================================================           
00461400                                                                                    
00461500                                                                                    
00461600 PROCEDURE WRITELBUFFER;                                                            
00461700 %         ************                                                             
00461800 BEGIN                                                                              
00461900   LABEL FORCESEGMENTATION;                                                         
00462000   %                                                                                
00462100   WRITE(LINE,22,LBUF[*]);                                                          
00462200   REPLACE LBUF0 BY " " FOR 22 WORDS;                                               
00462300 END;                                                                               
00462400                                                                                    
00462500                                                                                    
00462600 PROCEDURE WRITEBUFFER;                                                             
00462700 %         ***********                                                              
00462800 BEGIN                                                                              
00462900   LABEL FORCESEGMENTATION;                                                         
00463000   IF LISTTOG THEN BEGIN                                                            
00463100     WRITE(LINE,22,LBUF[*]);                                                        
00463200     REPLACE LBUF0 BY " " FOR 22 WORDS;                                             
00463300   END;                                                                             
00463400   IF ERRLISTTOG THEN BEGIN                                                         
00463500     WRITE(ERRORFILE,14,LBUF[*]);                                                   
00463600     REPLACE LBUF0 BY " " FOR 22 WORDS;                                             
00463700   END;                                                                             
00463800 END; % OF WRITE BUFFER                                                             
00463900                                                                                    
00464000                                                                                    
00464100 PROCEDURE ERROR(NUMBER);                                                           
00464200 %         *****                                                                    
00464300 VALUE NUMBER;                                                                      
00464400 INTEGER NUMBER;                                                                    
00464500 BEGIN                                                                              
00464600   LABEL FOUND;                                                                     
00464700   INTEGER SEVERITY,J,MESSINDEX;                                                    
00464800   DEFINE ERRCODE[J]=ERRORMESSAGEINDEX[J]#;                                         
00464900                                                                                    
00465000 VALUE ARRAY ERRORMESSAGETEXT (                                                     
00465100 "NO MESSAGE TEXT STORED FOR ERROR NUMBER AT FAR RIGHT:",                           
00465200 "MISSING SEMICOLON AFTER PROGRAM HEADING (INSERTED)",                              
00465300 "MISSING . AFTER FINAL END (DO YOU HAVE THE RIGHT ENDS MATCHING?)",                
00465400 "NO HEADING TO PROGRAM",                                                           
00465500 "THIS CANNOT START A DECLARATION",                                                 
00465600 "EXECUTABLE PART MUST START WITH A -BEGIN-",                                       
00465700 "INVALID TERMINATION SYMBOL - EXPECTED 'END' (CHECK BEGIN/ENDS)",                  
00465800 "AN -END- EXPECTED (AND INSERTED HERE)",                                           
00465900 "DECLARED LABELS HAVE NOT BEEN LOCATED IN THE PRECEDING TEXT",                     
00466000 "THIS SYMBOL WAS EXPECTED TO BE A NAME",                                           
00466100 "EQUALS SIGN EXPECTED (AND INSERTED)",                                             
00466200 "UNEXPECTED CONTINUATION",                                                         
00466300 "SEMICOLON EXPECTED",                                                              
00466400 "THIS LABEL IS ALREADY DECLARED IN THIS PROCEDURE/FUNCTION",                       
00466500 "A LABEL MUST BE A SMALL UNSIGNED INTEGER (0<=LABEL<=9999)",                       
00466600 "COMMA EXPECTED",                                                                  
00466700 "NOT IMPLEMENTED",                                                                 
00466800 "INTEGER IS TOO LONG TO CONVERT (KEEP UNDER 12 DIGITS)",                           
00466900 "NO MATCHING QUOTE TO CLOSE STRING ON THIS LINE",                                  
00467000 "THE EMPTY STRING IS NOT PERMITTED",                                               
00467100 "THIS CHARACTER CANNOT BEGIN A PASCAL SYMBOL",                                     
00467200 "THIS NAME HAS ALREADY BEEN INCOMPATIBLY DECLARED",                                
00467300 "WHERE IS FRACTION DIGIT AFTER POINT?",                                            
00467400 "MORE THAN 3 EXPONENT DIGITS IS NOT ALLOWED",                                      
00467500 "WHERE IS EXPONENT DIGIT AFTER -E-?",                                              
00467600 "THIS REAL VALUE IS NOT REPRESENTABLE ON B6700 COMPUTER",                          
00467700 "RIGHT CURLY BRACKET WITHOUT MATCHING LEFT BRACKET",                               
00467800 "NAME ALREADY DECLARED WITH INCOMPATIBLE USAGE",                                   
00467900 "NAME NOT YET DECLARED (MIS-SPELT? OMITTED?)",                                     
00468000 "TYPE-NAME USED IN FORWARD POINTER DECLARATION, BUT NOT DEFINED YET",              
00468100 "LABEL NOT IN THIS PROCEDURE (BAD GOTO NOT IMPLEMENTED)",                          
00468200 "LABEL NOT DECLARED",                                                              
00468300 "YOU MUST HAVE A LABEL AFTER -GOTO- OR -GO-",                                      
00468400 "DISPLAY TABLE FULL (NESTING TOO DEEP FOR COMPILER)",                              
00468500 "PRECEDING OBJECT IS NOT OF RECORD TYPE",                                          
00468600 "A NAME MUST FOLLOW -WITH-",                                                       
00468700 "A -DO- EXPECTED (AND INSERTED)",                                                  
00468800 "NO := SIGN (WAS THIS SUPPOSED TO BE AN ASSIGNMENT OR NOT?)",                      
00468900 "TYPES OF VAR AND EXPRESSION ARE NOT COMPATIBLE",                                  
00469000 "CANNOT ASSIGN TO A FILE",                                                         
00469100 "THIS SYMBOL CANNOT START A VARIABLE (OR SELECTION THEREOF)",                      
00469200 "PRECEDING VARIABLE IS NOT OF TYPE ARRAY AND YET HERE IS AN INDEX..",              
00469300 "ONLY SCALAR TYPES CAN BE USED AS ACTUAL INDEX VALUES",                            
00469400 "TYPE OF INDEX NOT ASSIGNMENT COMPATIBLE WITH DECLARATION OF ARRAY",               
00469500 "SYMBOL NOT EXPECTED (A ] INTERPOLATED)",                                          
00469600 "PRECEDING VARIABLE IS NOT OF RECORD TYPE (AND YET HERE IS A . )",                 
00469700 "FIELD NAME NOT FOUND (WAS IT DECLARED FOR THIS RECORD TYPE/LEVEL ?)",             
00469800 "IMPOSSIBLE",                                                                      
00469900 "NO FIELD NAME FOLLOWS RECORD SELECTOR (.)",                                       
00470000 "PRECEDING VARIABLE IS NEITHER POINTER NOR FILE (SO WHY @ ?)",                     
00470100 "UNEXPECTED SYMBOL",                                                               
00470200 "CONTROLLED VARIABLE MUST BE A LOCAL VARIABLE (NOT -VAR- PARAMETER)",              
00470300 "CONTROLLED VARIABLE MUST BE SCALAR OR SUBRANGE (NOT REAL OR STRUCT)",             
00470400 "NO NAME FOLLOWS -FOR-",                                                           
00470500 "PRECEDING LIMIT EXPRESSION IS NOT OF SCALAR TYPE",                                
00470600 "PRECEDING EXPRESSION IS NOT COMPATIBLE WITH TYPE OF CONTROLLED VAR",              
00470700 "NO := SIGN IN -FOR- STATEMENT",                                                   
00470800 "NO -TO- OR -DOWNTO- FOLLOWS START VALUE",                                         
00470900 "PRECEDING EXPRESSION DOES NOT GIVE LOGICAL RESULT (TRUE/FALSE)",                  
00471000 "AN -END- EXPECTED (INTERPOLATED)",                                                
00471100 "A -THEN- EXPECTED (INTERPOLATED)",                                                
00471200 "AN -UNTIL- EXPECTED (INTERPOLATED)",                                              
00471300 "A -DO- EXPECTED (INTERPOLATED)",                                                  
00471400 "THIS SYMBOL CANNOT START A NEW STATEMENT",                                        
00471500 "CANNOT BE END OF STATEMENT (EXPECTED ONE OF ;/END/ELSE/UNTIL)",                   
00471600 "PRECEDING CASE EXPR MUST BE SCALAR OR SUBRANGE (NOT REAL OR STRUCT)",             
00471700 "AN -OF- EXPECTED (INTERPOLATED)",                                                 
00471800 "THIS CASE LABEL ALREADY MET IN THIS CASE CONSTRUCT",                              
00471900 "THIS CASE LABEL NOT IDENTICAL TO TYPE OF CASE EXPRESSION",                        
00472000 "COLON EXPECTED AT END OF CASE LABEL LIST",                                        
00472100 "THE RANGE OF THE CASE TABLE IS TOO BIG (>= 1000 LABELS INCL NULS)",               
00472200 "CANNOT HAVE TWO -ELSE-S IN A SINGLE CASE STATEMENT",                              
00472300 "THIS CONSTANT CANNOT BE LOADED (IS IT A STRING? LENGTH > 1?)",                    
00472400 "IMPOSSIBLE ACCESS MODE",                                                          
00472500 "CANNOT STORE INTO A NON-VARIABLE",                                                
00472600 "END-OF-INPUT REACHED (PROBABLY NOT ENOUGH -END-S TO MATCH)",                      
00472700 "HEAP TABLE FULL (TOO MANY NAMES, TYPES TO COMPILE)",                              
00472800 "RELEASE OF HEAP DATA WITH BAD INFO",                                              
00472900 "UNEXPECTED SYMBOL IN THIS CONTEXT",                                               
00473000 "COMPILER DISPLAY TABLE FULL (TOO MANY FUNC/PROC/RECORD NESTED)",                  
00473100 "TOO DEEP LEXICAL LEVEL FOR B6700/B7700 (PROC/FUNC NESTING)",                      
00473200 "THIS ACTUAL PARAMETER SHOULD START WITH A NAME",                                  
00473300 "INCOMPATIBLE TYPE PARAMETER IN STANDARD FUNC/PROC",                               
00473400 "SHOULD BE A POINTER TYPE",                                                        
00473500 "VARIANT TYPE NAME NOT FOUND",                                                     
00473600 "THIS IS NOT A VARIANT CONSTANT",                                                  
00473700 "CANNOT BE REAL OR STRING AS VARIANT",                                             
00473800 "VARIANT CONSTANT NOT COMPATIBLE WITH CASE IN RECORD DECL",                        
00473900 "OPEN PARENTHESIS EXPECTED (INTERPOLATED)",                                        
00474000 "CLOSE PARENTHESIS EXPECTED (INTERPOLATED)",                                       
00474100 "THIS SYMBOL CANNOT START A FACTOR",                                               
00474200 "MATCHING RIGHT PARENTHESIS EXPECTED (INTERPOLATED)",                              
00474300 "PRECEDING EXPR IS NOT TYPE LOGICAL (AFTER A -NOT-)",                              
00474400 "ONLY SCALAR EXPRS ALLOWED IN SET CONSTRUCTOR",                                    
00474500 "EXPR TYPE IS NOT IDENTICAL TO EARLIER EXPR",                                      
00474600 "MATCHING RIGHT BRACKET EXPECTED (INTERPOLATED)",                                  
00474700 "UNEXPECTED SYMBOL IN THIS CONTEXT, EXPECTED VARIABLE, CONSTANT,; ,(",             
00474800 "THIS VALUE EXCEEDS THE SET LIMITS",                                               
00474900 "SCALAR RANGE TOO LARGE FOR SET (0-47)",                                           
00475000 "LIMITS OF SUBRANGE MUST BE CONSTANTS",                                            
00475100 "DO YOU REALIZE THAT THIS IS THE EMPTY SET?",                                      
00475200 "ILLEGAL * OPERATOR (INCOMPATIBLE TYPES)",                                         
00475300 "ILLEGAL / OPERATOR (INCOMPATIBLE TYPES)",                                         
00475400 "ILLEGAL -DIV- OR -MOD- OPERATOR (INCOMPATIBLE TYPES)",                            
00475500 "ILLEGAL -AND- OR -OR- OPERATOR (NOT BOTH LOGICAL TYPE EXPRS)",                    
00475600 "ONLY INTEGER AND REAL TYPES MAY BE SIGNED",                                       
00475700 "ILLEGAL + OR - OPERATOR (INCOMPATIBLE TYPES)",                                    
00475800 "ILLEGAL -IN- RELATION (ELEMENT NOT COMPATIBLE WITH SET)",                         
00475900 "ILLEGAL -IN- RELATION (NOT A SET TYPE)",                                          
00476000 "ONLY =,NEQ PERMITTED IN POINTER RELATIONS",                                       
00476100 "RELATIONS <, > NOT PERMITTED BETWEEN SETS",                                       
00476200 "ONLY =, NEQ PERMITTED IN GENERAL ARRAY/RECORD RELATIONS",                         
00476300 "YOU CANNOT COMPARE FILES",                                                        
00476400 "UNEXPECTED OPERATOR",                                                             
00476500 "THIS SYMBOL CANNOT START A CONSTANT",                                             
00476600 "THIS SYMBOL CANNOT START A SIMPLE TYPE",                                          
00476700 "ENUMERATION CONSTANTS MUST BE NAMES",                                             
00476800 "COMMA OR ) EXPECTED",                                                             
00476900 "ONLY SINGLE CHARS CAN BE SCALARS",                                                
00477000 "COLON EXPECTED (INTERPOLATED)",                                                   
00477100 "SUBRANGE LIMITS NOT OF SAME TYPE",                                                
00477200 "REAL SUBRANGES NOT PERMITTED",                                                    
00477300 "SUBRANGE LIMITS IN REVERSE ORDER OF SIZE",                                        
00477400 "EXPECTED FIELDNAME OR -CASE- IN RECORD DECL",                                     
00477500 "NOT NAME/,/:/OF IN A LIST",                                                       
00477600 "COMMA, COLON OR -OF- EXPECTED",                                                   
00477700 "COMMA OR COLON EXPECTED",                                                         
00477800 "COLON OR -OF- EXPECTED (INTERPOLATED)",                                           
00477900 "CASE VARIANT MUST BE SCALAR",                                                     
00478000 "THIS CANNOT BE A CASE VARIANT NAME",                                              
00478100 "VARIANT NOT COMPATIBLE WITH CASE EXPR",                                           
00478200 "THIS SYMBOL CANNOT START A TYPE",                                                 
00478300 "TYPE NAME EXPECTED AFTER @",                                                      
00478400 "THIS SYMBOL CANNOT START A PACKED TYPE",                                          
00478500 "LEFT BRACKET EXPECTED AFTER -ARRAY- SYMBOL",                                      
00478600 "ELEMENTS OF A SET MUST BE ENUMERATION TYPE (NOT INTEGER)",                        
00478700 "PROC/FUNC DOES NOT NEED SPEC (FORWARD DECLARED)",                                 
00478800 "EXPECTED VAR/PROC/FUNC OR NAME",                                                  
00478900 "EXTERNAL CONSTRUCT REQUIRES BINDINFO OPTION",                                     
00479000 "NAME EXPECTED",                                                                   
00479100 "FUNCTION VALUE CAN ONLY BE SCALAR OR POINTER TYPE",                               
00479200 "FILES CANNOT BE PASSED BY VALUE",                                                 
00479300 "NAME ALREADY DECLARED (FUNC/PROC CONFUSION?)",                                    
00479400 "NO PROCEDURE NAME",                                                               
00479500 "SEMICOLON EXPECTED (INTERPOLATED)",                                               
00479600 "ALREADY FORWARD DECL",                                                            
00479700 "EXPECTED BEGIN/PROC/FUNC/ ONLY HERE",                                             
00479800 "THIS PROC/FUNC CANNOT HAVE MORE PARAMETERS",                                      
00479900 "CANNOT USE -VAR- PARAMETER AS ACTUAL PARAMETER",                                  
00480000 "ACTUAL AND DECLARED PARAMETER TYPES INCOMPATIBLE",                                
00480100 "CANNOT USE EXPR OR CONSTANT FOR -VAR- PARAMETER",                                 
00480200 "PROC/FUNC DEMANDS MORE PARAMETERS",                                               
00480300 "THIS IS NOT A VALID FILE ATTRIBUTE",                                              
00480400 "= EXPECTED BUT NOT FOUND",                                                        
00480500 "THIS IS NOT A VALID MNEUMONIC FOR THIS FILE ATTRIBUTE",                           
00480600 "THIS IS NOT A VALID VALUE FOR THIS FILE ATTRIBUTE",                               
00480700 "AN INTEGER WAS EXPECTED BUT NOT FOUND",                                           
00480800 "A CHARACTER STRING WAS EXPECTED BUT NOT FOUND",                                   
00480900 "A STRING OR INTEGER WAS EXPECTED BUT NOT FOUND",                                  
00481000 " TRUE  OR  FALSE  MUST BE USED WITH A BOOLEAN FILE ATTRIBUTE",                    
00481100 "MAXRECSIZE TOO SMALL FOR RECORD SIZE",                                            
00481200 "ILLEGAL FORMAT CHARACTER",                                                        
00481300 "INTEGER TOO LARGE -- TRUNCATED TO 65535",                                         
00481400 "INTEGER CONSTANT EXPECTED",                                                       
00481500 "AN EXPRESSION WAS EXPECTED HERE",                                                 
00481600 "UNSPECIFIED FIELD WIDTH",                                                         
00481700 "DECIMAL FIELD NOT COMPATIBLE WITH FIELD WIDTH",                                   
00481800 "MISSING DECIMAL POINT IN D,E,F,G FORMAT",                                         
00481900 "EMPTY EDITING SPECIFICATION",                                                     
00482000 "ILLEGAL REPEAT COUNT",                                                            
00482100 "ERROR IN HOLLERITH CHARACTER COUNT",                                              
00482200 "ILLEGAL INCREMENT FOR T FORMAT",                                                  
00482300 "UNSPECIFIED DECIMAL FIELD",                                                       
00482400 "UNSPECIFIED SCALE FACTOR",                                                        
00482500 "UNMATCHED STRING-BRACKET CHARACTER",                                              
00482600 "TOO MANY RIGHT PARENTHESES",                                                      
00482700 "REPEAT = 0 -- PHRASE SKIPPED",                                                    
00482800 "STRING TOO LONG",                                                                 
00482900 "INVALID STRING CHARACTER",                                                        
00483000 "INVALID STRING CODE OR ILLEGAL STRING SYNTAX",                                    
00483100 "STRING TOO LONG -- > 256 CHARACTERS",                                             
00483200 "IDENTIFIER OR BEGIN/PROC/FUNC EXPECTED HERE",                                     
00483300 "INVALID UNIT FEATURE",                                                            
00483400 "FORMAT IDENTIFIER EXPECTED BUT NOT FOUND",                                        
00483500 "GO TO STATEMENTS ARE NOT ALLOWED IN LISTS",                                       
00483600 "READ LIST ELEMENTS MUST BE SIMPLE VARIABLES",                                     
00483700 "LIST ELEMENTS MUST BE VARIABLES OR EXPRESSIONS OF PREDEFINED TYPE",               
00483800 "NO LIST ELEMENT WAS FOUND IN THIS I/O LIST",                                      
00483900 "FILE NAME EXPECTED",                                                              
00484000 "INVALID CLOSE OPTION",                                                            
00484100 "AN INTEGER OR REAL WAS EXPECTED HERE",                                            
00484200 "A REAL CONSTANT OR VARIABLE WAS EXPECTED HERE",                                   
00484300 "AN INTEGER CONSTANT OR VARIABLE WAS EXPECTED HERE",                               
00484400 "A SET ELEMENT WAS EXPECTED HERE",                                                 
00484500 "A SCALAR TYPE (NOT REAL) WAS EXPECTED HERE",                                      
00484600 "A RECORD NUMBER MUST BE SPECIFIED IN A SEEK OR SPACE STATEMENT",                  
00484700 "EXPRESSION TYPES FOR MAX/MIN MUST BE IDENTICAL",                                  
00484800 "AN ARRAY NAME WAS EXPECTED HERE",                                                 
00484900 "STRINGS CANNOT BE USED WITH RADIX FORMATS",                                       
00485000 "THE -D- FORMAT IS INVALID FOR THIS TYPE OF ELEMENT",                              
00485100 "ONLY REALS MAY BE PRINTED WITH -E- FORMAT",                                       
00485200 "THESE COMPILER OPTIONS ARE IGNORED IN B6700 PASCAL",                              
00485300 "FILE PARAMETERS IGNORED IN B6700 PASCAL",                                         
00485400 "UNIMPLEMENTED VALUE ARRAY/RECORDS",                                               
00485500 "SET BOUNDS MUST LIE BETWEEN 0 AND 47 (INCLUSIVE)",                                
00485600 "LIST ELEMENTS MUST BE SIMPLE VARIABLES OR SCALARS",                               
00485700 "LIST ELEMENTS MUST BE SIMPLE VARS, SCALARS, STRINGS OR EXPRESSIONS",              
00485800 "ELSE IN CASE IS NOT STANDARD PASCAL",                                             
00485900 "RECORD ORIENTED I/O IS NOT STANDARD PASCAL",                                      
00486000 "THIS IDENTIFIER IS NOT UNIQUE OVER FIRST 8 CHARACTERS AT THIS LEVEL",             
00486100 "THIS PROCEDURE/FUNCTION IS NOT STANDARD PASCAL",                                  
00486200 "THIS IDENTIFIER IS NOT UNIQUE OVER FIRST 8 CHARACTERS IN PROGRAM",                
00486300 "THIS IDENTIFIER HAS BEEN DEFINED AT ANOTHER LEVEL",                               
00486400 "YOU CANNOT ALTER A FOR STATEMENT CONTROL VARIABLE",                               
00486500 "THIS VAR PARAMETER IS A FOR STATEMENT CONTROL VARIABLE",                          
00486600 "UNEXPECTED ; IN COMMENT - HAVE YOU FORGOTTEN TO CLOSE COMMENT?",                  
00486700 "TYPE MUST BE SCALAR AND NOT INTEGER OR REAL",                                     
00486800 "VALUE LIES OUTSIDE THE BOUNDS OF THE TYPE",                                       
00486900 "FILE TYPES MUST BE PREDEFINED TYPES OR ARRAYS OR RECORDS",                        
00487000 "A PROCEDURE HAS BEEN DECLARED FORWARD BUT NO BODY SPECIFIED",                     
00487100 "TYPE CHANGES ARE NOT STANDARD PASCAL",                                            
00487200 "THIS EXPRESSION REQUIRES THE OUTPUT FILE TO BE EXPLICITLY STATED",                
00487300 "PACKED FIELD < 48 BITS ARE NOT ALLOWED AS VAR PARAMETERS",                        
00487400 "THIS ARRAY MUST BE PACKED",                                                       
00487500 "THIS ARRAY MUST NOT BE PACKED",                                                   
00487600 "UNPACKED ARRAY TOO SMALL",                                                        
00487700 "DISPOSE ALWAYS RETURNS A NIL POINTER IN B6700 PASCAL",                            
00487800 "TAG FIELD VALUES IGNORED IN B6700 PASCAL",                                        
00487900 "STRING PADDING IS NOT STANDARD PASCAL",                                           
00488000 "THIS LABEL HAS ALREADY BEEN SITED",                                               
00488100 "AN ARRAY WITH INTEGER BOUNDS IN NOT PERMITTED",                                   
00488200 "POINTERS TO FILES NOT PERMITTED IN B6700 PASCAL",                                 
00488300 "ARRAY BOUNDS MUST BE A SIMPLE TYPE",                                              
00488400 "YOU CANNOT USE READLN OR WRITELN FOR FORMATTED I/O",                              
00488500 "THIS CONTROL VARIABLE IS NOT LOCAL TO THIS BLOCK",                                
00488600 "INVALID ASSIGNMENT TO A FUNCTION VARIABLE",                                       
00488700 "THIS PROCEDURE/FUNCTION CANNOT BE PASSED AS A PARAMETER",                         
00488800 "THIS PROCEDURE/FUNCTION IS NOT COMPATIBLE WITH THAT DEFINED EARLIER",             
00488900 "THE ACTUAL AND FORMAL PARAMETERS ARE NOT IDENTICAL",                              
00489000 "EXPRESSION TYPE IS NOT ASSIGNMENT COMPATIBLE WITH VAR",                           
00489100 "TOO MANY FILES IN SUBPROGRAM",                                                    
00489200 "USE OF EOLN ON A NON-TEXT FILE IS NON-STANDARD",                                  
00489300 "I/O INVOLVING USER DEFINED SCALARS IS NOT STANDARD PASCAL",                       
00489400 "I/O INVOLVING STRINGS IS NOT STANDARD PASCAL",                                    
00489500 "RADIX OUTPUT IS NOT STANDARD PASCAL",                                             
00489600 "TYPE OF VARIABLE AND TYPE OF FILE ARE NOT ASSIGNMENT COMPATIBLE",                 
00489700 "THIS PRODUCT WILL ALWAYS OVERFLOW",                                               
00489800 "YOU ARE TRYING TO DIVIDE BY ZERO",                                                
00489900 "EXPRESSION YIELDS A VALUE OUTSIDE THE REQUIRED RANGE",                            
00490000 "FOR STATEMENT LIMITS WILL CAUSE A BOUNDS ERROR ON CONTROL VARIABLE",              
00490100 "THIS CASE LABEL CANNOT BE REACHED",                                               
00490200 "A STRING WAS EXPECTED HERE",                                                      
00490300 "USING A FILENAME IN RESET/REWRITE IS NOT STANDARD PASCAL",                        
00490400 "LIST ELEMENTS MUST BE OF PREDEFINED TYPE OR SCALARS OR STRINGS",                  
00490500 "A SET TYPE WAS EXPECTED HERE",                                                    
00490600 "SET SIZE EXCEEDS THE MAXIMUM PERMISSIBLE",                                        
00490700 "AUTOBIND NOT AVAILABLE",                                                          
00490800 "INTERNAL BINDER CONTROL ARRAY TOO SMALL",                                         
00490900 "A PROGRAM IDENTIFIER WAS EXPECTED HERE",                                          
00491000 "EXTERNAL PROCEDURES/FUNCTIONS ARE NOT STANDARD PASCAL",                           
00491100 "FILE ATTRIBUTES CONTAINING RESERVED WORDS MUST BE ENCLOSED IN QUOTES"             
00491200 );                                                                                 
00491300                                                                                    
00491400 VALUE ARRAY ERRORMESSAGEINDEX (                                                    
00491500   4"003500000001",                                                                 
00491600   4"0032000909C4",                                                                 
00491700   4"0040001209C5",                                                                 
00491800   4"0015001D09C6",                                                                 
00491900   4"001F002109CE",                                                                 
00492000   4"0029002709CF",                                                                 
00492100   4"003E002E09D0",                                                                 
00492200   4"0025003909D8",                                                                 
00492300   4"003B004009D9",                                                                 
00492400   4"0025004A08FC",                                                                 
00492500   4"0025004A0910",                                                                 
00492600   4"0025004A091A",                                                                 
00492700   4"0023005108FD",                                                                 
00492800   4"002300510911",                                                                 
00492900   4"0017005708FE",                                                                 
00493000   4"001700570913",                                                                 
00493100   4"00170057091F",                                                                 
00493200   4"0012005B08FF",                                                                 
00493300   4"0012005B0909",                                                                 
00493400   4"0012005B0912",                                                                 
00493500   4"0012005B091E",                                                                 
00493600   4"0012005B0A2B",                                                                 
00493700   4"0039005E0906",                                                                 
00493800   4"003900680907",                                                                 
00493900   4"00390068090A",                                                                 
00494000   4"003900680A7A",                                                                 
00494100   4"003900680A82",                                                                 
00494200   4"000E00720908",                                                                 
00494300   4"000E007209BF",                                                                 
00494400   4"000E00720A2C",                                                                 
00494500   4"000E00720B2C",                                                                 
00494600   4"000E00720B42",                                                                 
00494700   4"000E00720B57",                                                                 
00494800   4"000E00720B58",                                                                 
00494900   4"000F0075091D",                                                                 
00495000   4"003500780898",                                                                 
00495100   4"002E00810899",                                                                 
00495200   4"00210089089A",                                                                 
00495300   4"002B008F089B",                                                                 
00495400   4"0030009708A2",                                                                 
00495500   4"0024009F089C",                                                                 
00495600   4"002A00A5089D",                                                                 
00495700   4"002200AC089E",                                                                 
00495800   4"003600B2089F",                                                                 
00495900   4"003100BB08A0",                                                                 
00496000   4"002D00C408AC",                                                                 
00496100   4"002B00CC08AD",                                                                 
00496200   4"004200D408B6",                                                                 
00496300   4"003600DF0A78",                                                                 
00496400   4"001200E80A79",                                                                 
00496500   4"001200E80A83",                                                                 
00496600   4"002A00EB0A7B",                                                                 
00496700   4"003200F21235",                                                                 
00496800   4"002600FB0A66",                                                                 
00496900   4"001901020A64",                                                                 
00497000   4"001E01070A67",                                                                 
00497100   4"001E01070A61",                                                                 
00497200   4"003A010C0A52",                                                                 
00497300   4"002E01160A54",                                                                 
00497400   4"002E01160AF9",                                                                 
00497500   4"0017011E0A50",                                                                 
00497600   4"003A01220A8C",                                                                 
00497700   4"0042012C0A8D",                                                                 
00497800   4"003401370A8E",                                                                 
00497900   4"004101400A8F",                                                                 
00498000   4"0026014B0A90",                                                                 
00498100   4"003F01520A91",                                                                 
00498200   4"0043015D0A92",                                                                 
00498300   4"000A01690E7B",                                                                 
00498400   4"0029016B0A94",                                                                 
00498500   4"003B01720A95",                                                                 
00498600   4"0011017C0A93",                                                                 
00498700   4"0042017F0A5A",                                                                 
00498800   4"0043018A0A5B",                                                                 
00498900   4"001501960A5C",                                                                 
00499000   4"0030019A0A5D",                                                                 
00499100   4"004201A20A5E",                                                                 
00499200   4"001D01AD0A5F",                                                                 
00499300   4"002701B20A60",                                                                 
00499400   4"003E01B90A33",                                                                 
00499500   4"003E01B90A3D",                                                                 
00499600   4"003E01B90A47",                                                                 
00499700   4"002001C40A28",                                                                 
00499800   4"002001C40A74",                                                                 
00499900   4"002001C40939",                                                                 
00500000   4"002001CA0A32",                                                                 
00500100   4"002201D00A3C",                                                                 
00500200   4"001E01D60A46",                                                                 
00500300   4"002801DB0A84",                                                                 
00500400   4"003D01E20A85",                                                                 
00500500   4"004301ED0A6E",                                                                 
00500600   4"001F01F90A6F",                                                                 
00500700   4"001F01F90937",                                                                 
00500800   4"001F01F9093A",                                                                 
00500900   4"001F01F9093D",                                                                 
00501000   4"001F01F90950",                                                                 
00501100   4"003201FF0A70",                                                                 
00501200   4"003802080A71",                                                                 
00501300   4"002802120A72",                                                                 
00501400   4"004102190A73",                                                                 
00501500   4"003202240A76",                                                                 
00501600   4"003C022D0AA2",                                                                 
00501700   4"001602370E88",                                                                 
00501800   4"001602370E74",                                                                 
00501900   4"0020023B0AA1",                                                                 
00502000   4"003A0241106C",                                                                 
00502100   4"003A02411194",                                                                 
00502200   4"0032024B1090",                                                                 
00502300   4"002202540CA9",                                                                 
00502400   4"0021025A0927",                                                                 
00502500   4"0021025A095D",                                                                 
00502600   4"0021025A0945",                                                                 
00502700   4"0021025A094E",                                                                 
00502800   4"0021025A093E",                                                                 
00502900   4"0021025A0960",                                                                 
00503000   4"0021025A0966",                                                                 
00503100   4"0021025A0969",                                                                 
00503200   4"0021025A0964",                                                                 
00503300   4"0021025A0972",                                                                 
00503400   4"0021025A0971",                                                                 
00503500   4"0021025A09AB",                                                                 
00503600   4"003E02601108",                                                                 
00503700   4"003E02601165",                                                                 
00503800   4"003A026B1164",                                                                 
00503900   4"002E02750AA3",                                                                 
00504000   4"0031027D0B3B",                                                                 
00504100   4"001802860B36",                                                                 
00504200   4"001B028A0B37",                                                                 
00504300   4"001E028F0B38",                                                                 
00504400   4"002302940B39",                                                                 
00504500   4"0038029A0B3A",                                                                 
00504600   4"002802A40B3C",                                                                 
00504700   4"002802A4094D",                                                                 
00504800   4"002802A40B1A",                                                                 
00504900   4"002902AB0B3D",                                                                 
00505000   4"002902AB0959",                                                                 
00505100   4"002902AB094F",                                                                 
00505200   4"002902AB0866",                                                                 
00505300   4"002902AB0B5F",                                                                 
00505400   4"002902AB0B1B",                                                                 
00505500   4"002902AB0B3F",                                                                 
00505600   4"002102B20B0E",                                                                 
00505700   4"003202B80B0F",                                                                 
00505800   4"003202B809AC",                                                                 
00505900   4"003202C10B10",                                                                 
00506000   4"002C02CA0B11",                                                                 
00506100   4"002A02D20B12",                                                                 
00506200   4"002E02D90B13",                                                                 
00506300   4"002E02D90936",                                                                 
00506400   4"002E02D90B55",                                                                 
00506500   4"004302E10B14",                                                                 
00506600   4"002102ED0B15",                                                                 
00506700   4"002502F30B16",                                                                 
00506800   4"002502F30AF8",                                                                 
00506900   4"002402FA0B17",                                                                 
00507000   4"002A03000709",                                                                 
00507100   4"002703070B04",                                                                 
00507200   4"0027030E0B05",                                                                 
00507300   4"003403150B06",                                                                 
00507400   4"003403150B07",                                                                 
00507500   4"003C031E0B08",                                                                 
00507600   4"003C031E0AFD",                                                                 
00507700   4"002903280AFA",                                                                 
00507800   4"002903280925",                                                                 
00507900   4"002903280926",                                                                 
00508000   4"002903280AFE",                                                                 
00508100   4"002903280928",                                                                 
00508200   4"002C032F0AFB",                                                                 
00508300   4"002C032F0AFC",                                                                 
00508400   4"003703370AF0",                                                                 
00508500   4"002603410AF1",                                                                 
00508600   4"002903480AF2",                                                                 
00508700   4"0029034F0AF3",                                                                 
00508800   4"003703560AF4",                                                                 
00508900   4"003703560AF5",                                                                 
00509000   4"001803600AF6",                                                                 
00509100   4"001303640AF7",                                                                 
00509200   4"002303680924",                                                                 
00509300   4"0026036E0956",                                                                 
00509400   4"002303750957",                                                                 
00509500   4"0013037B0958",                                                                 
00509600   4"0020037F095A",                                                                 
00509700   4"001D0385095B",                                                                 
00509800   4"001D03850973",                                                                 
00509900   4"001D03850999",                                                                 
00510000   4"001D0385091C",                                                                 
00510100   4"001D03850A87",                                                                 
00510200   4"0020038A095C",                                                                 
00510300   4"001C0390095E",                                                                 
00510400   4"001C03900933",                                                                 
00510500   4"00280395095F",                                                                 
00510600   4"002B039C0951",                                                                 
00510700   4"001903A40942",                                                                 
00510800   4"001D03A90943",                                                                 
00510900   4"001703AE096B",                                                                 
00511000   4"001703AE091B",                                                                 
00511100   4"002503B20944",                                                                 
00511200   4"002503B20946",                                                                 
00511300   4"002503B2094C",                                                                 
00511400   4"001B03B90947",                                                                 
00511500   4"001B03B90948",                                                                 
00511600   4"001B03B90949",                                                                 
00511700   4"002203BE0952",                                                                 
00511800   4"002203BE094A",                                                                 
00511900   4"002503C4094B",                                                                 
00512000   4"001F03CB092E",                                                                 
00512100   4"001A03D10930",                                                                 
00512200   4"002603D60931",                                                                 
00512300   4"002A03DD0932",                                                                 
00512400   4"003803E4093B",                                                                 
00512500   4"003803E4093C",                                                                 
00512600   4"002F03EE0961",                                                                 
00512700   4"001E03F60974",                                                                 
00512800   4"001E03F60970",                                                                 
00512900   4"002B03FB0962",                                                                 
00513000   4"002B03FB0965",                                                                 
00513100   4"002B03FB09A8",                                                                 
00513200   4"000D04030963",                                                                 
00513300   4"000D04030968",                                                                 
00513400   4"000D0403096A",                                                                 
00513500   4"000D0403096F",                                                                 
00513600   4"000D04030998",                                                                 
00513700   4"000D040309A9",                                                                 
00513800   4"003104060967",                                                                 
00513900   4"003104060997",                                                                 
00514000   4"001F040F096C",                                                                 
00514100   4"002C04150992",                                                                 
00514200   4"0011041D0993",                                                                 
00514300   4"00210420099A",                                                                 
00514400   4"00210420099C",                                                                 
00514500   4"00210420099F",                                                                 
00514600   4"00140426099B",                                                                 
00514700   4"0023042A099E",                                                                 
00514800   4"002A043009A6",                                                                 
00514900   4"0030043F09AA",                                                                 
00515000   4"002F044709AE",                                                                 
00515100   4"0021044F09AD",                                                                 
00515200   4"00220455085D",                                                                 
00515300   4"0018045B085E",                                                                 
00515400   4"0035045F085F",                                                                 
00515500   4"003104680860",                                                                 
00515600   4"002504710861",                                                                 
00515700   4"002D04780862",                                                                 
00515800   4"002E04800863",                                                                 
00515900   4"003C04880864",                                                                 
00516000   4"003C04880865",                                                                 
00516100   4"00240492093F",                                                                 
00516200   4"0018049809B1",                                                                 
00516300   4"0027049C09B2",                                                                 
00516400   4"001904A309B3",                                                                 
00516500   4"001F04A80B7F",                                                                 
00516600   4"001F04A80B73",                                                                 
00516700   4"001704AE09B4",                                                                 
00516800   4"002D04B209B5",                                                                 
00516900   4"002704BA09B6",                                                                 
00517000   4"001B04C109B7",                                                                 
00517100   4"001404C609B8",                                                                 
00517200   4"002204CA09B9",                                                                 
00517300   4"001E04D009BA",                                                                 
00517400   4"001904D509BB",                                                                 
00517500   4"001804DA09BC",                                                                 
00517600   4"002204DE09BD",                                                                 
00517700   4"001A04E409BE",                                                                 
00517800   4"001C04E909C0",                                                                 
00517900   4"000F04EE09C1",                                                                 
00518000   4"001804F109C2",                                                                 
00518100   4"002C04F509C3",                                                                 
00518200   4"002304FD0A29",                                                                 
00518300   4"002B05030A2A",                                                                 
00518400   4"0014050B0B54",                                                                 
00518500   4"0028050F0B59",                                                                 
00518600   4"002905160A7C",                                                                 
00518700   4"002B051D0B68",                                                                 
00518800   4"004105250B69",                                                                 
00518900   4"004105250B6A",                                                                 
00519000   4"004105250B6B",                                                                 
00519100   4"004105250B6C",                                                                 
00519200   4"004105250B6D",                                                                 
00519300   4"002A05300B5E",                                                                 
00519400   4"001205370B2D",                                                                 
00519500   4"001205370B2F",                                                                 
00519600   4"001205370B35",                                                                 
00519700   4"0014053A0B2E",                                                                 
00519800   4"0024053E0B31",                                                                 
00519900   4"002D05440B32",                                                                 
00520000   4"0031054C0B30",                                                                 
00520100   4"001F05550B33",                                                                 
00520200   4"002A055B0B34",                                                                 
00520300   4"003E05620B5A",                                                                 
00520400   4"002E056D0B3E",                                                                 
00520500   4"001F05750B40",                                                                 
00520600   4"0029057B0B7E",                                                                 
00520700   4"0029057B0B72",                                                                 
00520800   4"003205820B80",                                                                 
00520900   4"003205820B74",                                                                 
00521000   4"0029058B0B76",                                                                 
00521100   4"003205921838",                                                                 
00521200   4"0027059B1965",                                                                 
00521300   4"002105A209B0",                                                                 
00521400   4"003005A80940",                                                                 
00521500   4"003105B00B75",                                                                 
00521600   4"004205B90B77",                                                                 
00521700   4"002305C4068D",                                                                 
00521800   4"002A05CA05E9",                                                                 
00521900   4"002A05CA0772",                                                                 
00522000   4"004305D104BB",                                                                 
00522100   4"002E05DD0756",                                                                 
00522200   4"004005E504BC",                                                                 
00522300   4"003105F01845",                                                                 
00522400   4"003105F90A62",                                                                 
00522500   4"003105F90A53",                                                                 
00522600   4"003105F90B6E",                                                                 
00522700   4"003105F90B7C",                                                                 
00522800   4"003105F90B78",                                                                 
00522900   4"0036060205C8",                                                                 
00523000   4"003E060B04BD",                                                                 
00523100   4"002B06160B18",                                                                 
00523200   4"0029061E0B19",                                                                 
00523300   4"003806250941",                                                                 
00523400   4"003B062F1592",                                                                 
00523500   4"002406390734",                                                                 
00523600   4"0040063F0B5B",                                                                 
00523700   4"0038064A09A5",                                                                 
00523800   4"001906540B43",                                                                 
00523900   4"001D06590B41",                                                                 
00524000   4"0018065E0B44",                                                                 
00524100   4"00340662073B",                                                                 
00524200   4"0028066B073C",                                                                 
00524300   4"00250672066B",                                                                 
00524400   4"002106790A86",                                                                 
00524500   4"002D067F0934",                                                                 
00524600   4"002F0687092F",                                                                 
00524700   4"0022068F0935",                                                                 
00524800   4"003206950B5C",                                                                 
00524900   4"0030069E067B",                                                                 
00525000   4"002906A60A55",                                                                 
00525100   4"003706AD09A2",                                                                 
00525200   4"004306B709A3",                                                                 
00525300   4"003206C309A7",                                                                 
00525400   4"003506CC0A51",                                                                 
00525500   4"003506CC09AF",                                                                 
00525600   4"001C06D511AB",                                                                 
00525700   4"002E06DA075D",                                                                 
00525800   4"003906E2078E",                                                                 
00525900   4"003906E20799",                                                                 
00526000   4"003906E2079B",                                                                 
00526100   4"002C06EC079A",                                                                 
00526200   4"002C06EC0791",                                                                 
00526300   4"002306F40792",                                                                 
00526400   4"002306F4079C",                                                                 
00526500   4"003F06FA0B7D",                                                                 
00526600   4"002107050AE6",                                                                 
00526700   4"0020070B0AE7",                                                                 
00526800   4"0034071108CA",                                                                 
00526900   4"0042071A0A1E",                                                                 
00527000   4"00210725068F",                                                                 
00527100   4"001A072B0B22",                                                                 
00527200   4"00380730073D",                                                                 
00527300   4"003E073A0B84",                                                                 
00527400   4"001C07450B26",                                                                 
00527500   4"0028074A097E",                                                                 
00527600   4"0016075103FC",                                                                 
00527700   4"0027075507E5",                                                                 
00527800   4"0026075C09C7",                                                                 
00527900   4"00350763057B",                                                                 
00528000   4"0044076C0867");                                                                
00528100                                                                                    
00528200 DEFINE                                                                             
00528300   NOOFERRORMESSAGES =  261#,                                                       
00528400   NOOFERRORNUMBERS =  366#;                                                        
00528500                                                                                    
00528600                                                                                    
00528700   SEVERITY:=NUMBER DIV 1000;                                                       
00528800   IF (SEVERITY > 6)                                                                
00528900     OR (SEVERITY <= 0) THEN SEVERITY:=2;                                           
00529000   FOR J:=0 UPTO (NOOFERRORNUMBERS-1) DO BEGIN                                      
00529100     IF (ERRCODE[J].LOWFIELD = NUMBER) THEN GOTO FOUND;                             
00529200   END;                                                                             
00529300   J:=0;                                                                            
00529400 FOUND:                                                                             
00529500   MESSINDEX:=ERRCODE[J].MIDFIELD;                                                  
00529600   %                                                                                
00529700   IF LISTTOG OR NOT ERRLISTTOG THEN BEGIN                                          
00529800     IF NOT LISTTOG THEN BEGIN                                                      
00529900       IF ((SEVERITY=1 OR SEVERITY=6) AND WARNINGSTOG) OR                           
00530000          NOT ((SEVERITY=1) OR (SEVERITY=6)) THEN BEGIN                             
00530100         IF NOT HEADINGPRINTED THEN BEGIN                                           
00530200           HEADING;                                                                 
00530300         END;                                                                       
00530400         EDITLINE(CARDBUF[0]);                                                      
00530500         WRITELBUFFER;                                                              
00530600       END;                                                                         
00530700     END;                                                                           
00530800     IF (SEVERITY NEQ 5) THEN BEGIN                                                 
00530900       IF ((SEVERITY=1 OR SEVERITY=6) AND ( WARNINGSTOG))                           
00531000         OR NOT((SEVERITY=1) OR (SEVERITY=6)) THEN                                  
00531100       BEGIN                                                                        
00531200         REPLACE LBUF[16+73-INSYSTART] BY "*" FOR (INSYSTART-INSYK);                
00531300         WRITELBUFFER;                                                              
00531400       END;                                                                         
00531500     END;                                                                           
00531600     REPLACE LBUF[16] BY POINTER(ERRORMESSAGETEXT[MESSINDEX])                       
00531700       FOR (ERRCODE[J].TOPFIELD);                                                   
00531800     CASE SEVERITY OF BEGIN                                                         
00531900                                                                                    
00532000     1:                                                                             
00532100       REPLACE LBUF0 BY "W A R N I N G";                                            
00532200       REPLACE LBUF[106] BY "W", NUMBER FOR 4 DIGITS;                               
00532300     2: 3: 4: 5:                                                                    
00532400       NOOFERRORS:=NOOFERRORS+1;                                                    
00532500       REPLACE LBUF0 BY ">" FOR 6,                                                  
00532600                        NOOFERRORS FOR 4 DIGITS,                                    
00532700                        ">" FOR 6;                                                  
00532800       REPLACE LBUF[106] BY "E", NUMBER FOR 4 DIGITS;                               
00532900     6:                                                                             
00533000       REPLACE LBUF0 BY "N O T E :";                                                
00533100       REPLACE LBUF[106] BY "N", NUMBER FOR 4 DIGITS;                               
00533200                                                                                    
00533300     END; % OF CASE                                                                 
00533400     IF ((SEVERITY=1 OR SEVERITY=6) AND ( WARNINGSTOG))                             
00533500       OR NOT ((SEVERITY=1) OR (SEVERITY=6)) THEN                                   
00533600       WRITELBUFFER;                                                                
00533700     REPLACE  LBUF0 BY " " FOR 22 WORDS;                                            
00533800     IF (SEVERITY >= 3) AND (SEVERITY <= 5) THEN BEGIN                              
00533900       CASE SEVERITY OF BEGIN                                                       
00534000                                                                                    
00534100       3:                                                                           
00534200         REPLACE LBUF0 BY "*" FOR 16,                                               
00534300                          "POSSIBLE COMPILER FAULT:",                               
00534400                          " PLEASE NOTIFY STAFF OF CIRCUMSTANCES";                  
00534500       4:                                                                           
00534600         REPLACE LBUF0 BY "*" FOR 22 WORDS;                                         
00534700         REPLACE LBUF[15] BY " CONTINUING COMPILATION IS POINTLESS: ",              
00534800                             "ABORTING. ";                                          
00534900       5:                                                                           
00535000         REPLACE LBUF[16] BY "(THE CAUSE OF ABOVE ERROR LIES EARLIER IN "           
00535100           "THE PROGRAM - DETECTED HERE AS THIS IS CLOSE OF A SECTION)";            
00535200                                                                                    
00535300       END;                                                                         
00535400       WRITELBUFFER;                                                                
00535500     END; % OF IF                                                                   
00535600   END;   %OF IF LISTTOG                                                            
00535700                                                                                    
00535800   IF ERRLISTTOG THEN BEGIN                                                         
00535900     IF (SEVERITY <= 5) AND (SEVERITY >= 1) THEN BEGIN                              
00536000       IF NOT((SEVERITY=1 OR SEVERITY=6) AND (NOT WARNINGSTOG)) THEN                
00536100       BEGIN                                                                        
00536200         IF (SEVERITY=1) THEN BEGIN                                                 
00536300           REPLACE LBUF0 BY "WARNING AT LINE ";                                     
00536400         END ELSE BEGIN                                                             
00536500           REPLACE LBUF0 BY "ERROR AT LINE ";                                       
00536600         END;                                                                       
00536700         REPLACE IF(SEVERITY=1) THEN LBUF0+16 ELSE LBUF0+14 BY                      
00536800                   LINENUMBERPTR FOR 8,                                             
00536900                   ": ",                                                            
00537000                   CARDBUF[73-INSYSTART] FOR (INSYSTART-INSYK);                     
00537100         WRITE(ERRORFILE,12,LBUF[*]);                                               
00537200         REPLACE LBUF0 BY CARDBUF[0] FOR 72;                                        
00537300         WRITE(ERRORFILE,12,LBUF[0]);                                               
00537400         REPLACE LBUF0 BY " " FOR 22 WORDS;                                         
00537500         REPLACE LBUF0 BY POINTER(ERRORMESSAGETEXT[MESSINDEX])                      
00537600           FOR (ERRCODE[J].TOPFIELD);                                               
00537700         WRITE(ERRORFILE,12,LBUF[*]);                                               
00537800         REPLACE LBUF0 BY " " FOR 22 WORDS;                                         
00537900         IF ((SEVERITY > 1) AND NOT LISTTOG) THEN NOOFERRORS := * + 1;              
00538000       END;                                                                         
00538100     END;                                                                           
00538200   END; % OF IF ERRLISTTOG                                                          
00538300                                                                                    
00538400   CHECKERRORLIMIT;                                                                 
00538500   IF (SEVERITY = 4) THEN GOTO SHEERANDUTTERDISASTER;                               
00538600 END; % OF ERROR                                                                    
00538700                                                                                    
00538800                                                                                    
00538900 PROCEDURE FORWARDREFERROR(FIP);                                                    
00539000 %         ***************                                                          
00539100 TYPEIDENTPTR FIP;                                                                  
00539200 BEGIN                                                                              
00539300   TYPEIDENTPTR LIP;                                                                
00539400   INTEGER INDEX,NAMELENGTH;                                                        
00539500   %                                                                                
00539600   ERROR(2230);                                                                     
00539700   LIP:=FIP;                                                                        
00539800   DO BEGIN                                                                         
00539900     INDEX:=NAME(LIP);                                                              
00540000     NAMELENGTH:=HEAP[INDEX].[47:8];                                                
00540100     REPLACE LBUF0 BY " " FOR 10,                                                   
00540200                      "*" FOR 6,                                                    
00540300                      (POINTER(HEAP[INDEX])+1) FOR NAMELENGTH;                      
00540400     WRITEBUFFER;                                                                   
00540500     LIP:=NEXT(LIP);                                                                
00540600   END UNTIL (LIP = NIL);                                                           
00540700   FIP:=NIL;    % MAKE POINTER NIL                                                  
00540800 END; % OF FORWARD REF ERROR                                                        
00540900                                                                                    
00541000 INTEGER PROCEDURE INTRINSICADDR (INTADDR,INT);                                     
00541100 %                 *************                                                    
00541200 VALUE INT;                                                                         
00541300 INTEGER INTADDR,INT;                                                               
00541400 BEGIN                                                                              
00541500   IF (INTADDR = 0) THEN BEGIN                                                      
00541600     INTADDR := MAKED1SLOT;                                                         
00541700     D1STACK[INTADDR] := INT & 7[42:3];                                             
00541800     D1STACKTAGS[INTADDR] := 5;                                                     
00541900     IF CODETOG THEN BEGIN                                                          
00542000       REPLACE LBUF0 BY                                                             
00542100         "(01,",                                                                    
00542200         INTADDR FOR 5 DIGITS,                                                      
00542300         ") = SEPARATE SEG.DICT. INTRINSIC";                                        
00542400       WRITELBUFFER;                                                                
00542500     END;                                                                           
00542600   END;                                                                             
00542700   INTRINSICADDR := INTADDR;                                                        
00542800 END;  % OF INTRINSICADDR                                                           
00542900                                                                                    
00543000                                                                                    
00543100 PROCEDURE RUNTIMEERROR(J);                                                         
00543200 %         ************                                                             
00543300 VALUE J;                                                                           
00543400 INTEGER J;                                                                         
00543500 BEGIN                                                                              
00543600   DEFINE PASCALERRORINTR = 1#;                                                     
00543700   GENOP(MKST);                                                                     
00543800   GENV(NAMC,1,INTRINSICADDR(PASCALERRORADDR,                                       
00543900     PASCALINTRINSIC(PASCALERRORINTR)));                                            
00544000   GENLIT(J);                                                                       
00544100   GENOP(ENTR);                                                                     
00544200 END;                                                                               
00544300                                                                                    
00544400                                                                                    
00544500 %=======================================================================           
00544600 % HEAP MANIPULATION PROCEDURES                                                     
00544700 %=======================================================================           
00544800                                                                                    
00544900                                                                                    
00545000 PROCEDURE NEW(P,FSIZE);                                                            
00545100 %         ***                                                                      
00545200 VALUE FSIZE;                                                                       
00545300 INTEGER P,FSIZE;                                                                   
00545400 BEGIN                                                                              
00545500   LABEL FORCESEGMENTATION;                                                         
00545600   P:=TOPOFHEAP; TOPOFHEAP:=TOPOFHEAP+FSIZE;                                        
00545700   IF (TOPOFHEAP > HEAPLIMIT) THEN BEGIN                                            
00545800     ERROR(4240);                                                                   
00545900   END ELSE BEGIN                                                                   
00546000     REPLACE POINTER(HEAP[P]) BY 0 FOR FSIZE WORDS;                                 
00546100   END;                                                                             
00546200 END; % OF NEW                                                                      
00546300                                                                                    
00546400                                                                                    
00546500 DEFINE MARK(P)=                                                                    
00546600 %      ****                                                                        
00546700 BEGIN                                                                              
00546800   P:=TOPOFHEAP & CHECKPATTERN CHECKF;                                              
00546900 END#; % OF MARK                                                                    
00547000                                                                                    
00547100                                                                                    
00547200 PROCEDURE RELEASE(P);                                                              
00547300 %         *******                                                                  
00547400 INTEGER P;                                                                         
00547500 BEGIN                                                                              
00547600   INTEGER PA;                                                                      
00547700   %                                                                                
00547800   PA:=P.LOWFIELD;                                                                  
00547900   IF (P.CHECKF IS CHECKPATTERN) AND (PA > 0) AND                                   
00548000         (PA <= TOPOFHEAP) THEN BEGIN                                               
00548100     TOPOFHEAP:=PA;                                                                 
00548200   END ELSE BEGIN                                                                   
00548300     ERROR(3241);                                                                   
00548400   END;                                                                             
00548500   P:=NIL;                                                                          
00548600 END; % OF RELEASE                                                                  
00548700                                                                                    
00548800 PROCEDURE CREATEPOOL;                                                              
00548900 BEGIN                                                                              
00549000 REAL SEG;                                                                          
00549100 DATAPOOL:=SEG:=MAKED1SLOT;                                                         
00549200 D1STACKTAGS[SEG]:=5;                                                               
00549300 D1STACK[SEG]:=0 & 1[43:1] & 1[42:1] & 1[18:1];                                     
00549400 IF NAMESTOG OR CODETOG THEN                                                        
00549500   BEGIN                                                                            
00549600   REPLACE H BY SEG.[11:48] FOR 3;                                                  
00549700   REPLACE LBUF0+60 BY "SEGMENT ",H FOR 3 WITH HEXTOEBCDIC,                         
00549800     " CONTAINS DATAPOOL";                                                          
00549900   WRITETOLINE;                                                                     
00550000   END;                                                                             
00550100 POOLINDEX:=0;     POOLMAX:=6138;   %(1023 * 6)                                     
00550200 END;   %OF CREATEPOOL                                                              
00550300                                                                                    
00550400 PROCEDURE FLUSHPOOL;                                                               
00550500 BEGIN                                                                              
00550600 REAL REC;                                                                          
00550700 INTEGER                                                                            
00550800   LPOOLINDEX;                                                                      
00550900 LPOOLINDEX := (POOLINDEX DIV CHARSPERWORD) + 1;                                    
00551000 WRITESEGMENT(POOLWBUFFER,0,LPOOLINDEX,REC);                                        
00551100 D1STACK[DATAPOOL]:=* & REC [17:18] & POOLINDEX [39:20];                            
00551200 IF NAMESTOG OR CODETOG THEN                                                        
00551300   BEGIN                                                                            
00551400   REPLACE H BY DATAPOOL.[11:48] FOR 3;                                             
00551500   REPLACE LBUF0+60 BY "SEGMENT ",H FOR 3 WITH HEXTOEBCDIC,                         
00551600     "  LENGTH = ",POOLINDEX FOR 4 DIGITS," WORDS";                                 
00551700   WRITETOLINE;                                                                     
00551800   END;                                                                             
00551900 DATAPOOL:=0;                                                                       
00552000 NOOFSEGMENTS[WORDSEGTYPE] := *+1;                                                  
00552100 VALUEARRAYSIZE := *+(POOLINDEX DIV CHARSPERWORD)+1;                                
00552200 END;   %OF FLUSHPOOL                                                               
00552300                                                                                    
00552400 REAL PROCEDURE INSERTINTOPOOL(POINT,LENGTH);                                       
00552500 VALUE POINT,LENGTH; POINTER POINT; REAL LENGTH;                                    
00552600 BEGIN                                                                              
00552700 IF (POOLINDEX+LENGTH > POOLMAX) THEN FLUSHPOOL;                                    
00552800 IF DATAPOOL IS 0 THEN CREATEPOOL;                                                  
00552900 REPLACE POOLBUFFER[POOLINDEX] BY POINT FOR LENGTH;                                 
00553000 IF CODETOG THEN                                                                    
00553100   BEGIN                                                                            
00553200   REPLACE H BY DATAPOOL.[11:48] FOR 3;                                             
00553300   REPLACE LBUF0 BY "DATA INTO SEGMENT ",                                           
00553400     H FOR 3 WITH HEXTOEBCDIC," AT ",POOLINDEX FOR 4 DIGITS,                        
00553500     " FOR ",LENGTH FOR 3 DIGITS;                                                   
00553600   WRITETOLINE;                                                                     
00553700   END;                                                                             
00553800 INSERTINTOPOOL:=0 & DATAPOOL POOLSEGF & POOLINDEX POOLINDEXF;                      
00553900 GIDPLMT:=POOLINDEX ;                                                               
00554000 POOLINDEX:=*+LENGTH;                                                               
00554100 GVLEVEL:=1;  GDPLMT:=DATAPOOL;                                                     
00554200 GACCESS:=INDRCT;  GCHARSIZE:=CHARBITSIZE;                                          
00554300 END;   %OF INSERTINTOPOOL                                                          
00554400                                                                                    
00554500                                                                                    
00554600 %=======================================================================           
00554700 %                                                                                  
00554800 % INITIALIZATIONS FOR INSYMBOL                                                     
00554900 %                                                                                  
00555000 %=======================================================================           
00555100                                                                                    
00555200 DEFINE INITIALIZEINSYMBOL =                                                        
00555300         BEGIN                                                                      
00555400           INSYN  :=POINTER(NAMEBUF[0])+1;                                          
00555500           INSYP1 :=CARDBUF[00];                                                    
00555600           INSYP73:=CARDBUF[72];                                                    
00555700           INSYK  :=0;                                                              
00555800           INSYP:=INSYP73;                                                          
00555900           LINENUMBERPTR:=LINENUMBERBUF[0];                                         
00556000         END#;                                                                      
00556100                                                                                    
00556200 %=======================================================================           
00556300 %                                                                                  
00556400 % EXECUTABLE LEXICAL ANALYSER -INSYMBOL-                                           
00556500 %                                                                                  
00556600 %=======================================================================           
00556700                                                                                    
00556800 PROCEDURE INSYMBOL;                                                                
00556900 %         ********                                                                 
00557000 %***********************************************************************           
00557100 %*                                                                                 
00557200 %*      INSYMBOL                                                                   
00557300 %*                                                                                 
00557400 %***********************************************************************           
00557500 BEGIN                                                                              
00557600   LABEL RESCAN,WASRESERVEDWORD,COMSCAN,COM2SCAN;                                   
00557700                                                                                    
00557800   TRANSLATETABLE LCTOUC(EBCDIC TO EBCDIC,                                          
00557900     "abcdefghijklmnopqrstuvwxyz" TO                                                
00558000     "ABCDEFGHIJKLMNOPQRSTUVWXYZ");                                                 
00558100                                                                                    
00558200   % NO LOCAL VARIABLES: ALL IN GLOBAL AREA TO SPEED UP ENTRY/EXIT                  
00558300                                                                                    
00558400   DEFINE                                                                           
00558500                                                                                    
00558600     NEXTCH=                                                                        
00558700         BEGIN                                                                      
00558800           INSYP:=INSYP+1; INSYK:=INSYK-1;                                          
00558900         END#,                                                                      
00559000                                                                                    
00559100     CH=                                                                            
00559200         REAL(INSYP,1)#,                                                            
00559300                                                                                    
00559400     ITSA(SYM,OPR)=                                                                 
00559500         BEGIN                                                                      
00559600           SYMBOL:=SYM; OP:=OPR;                                                    
00559700           NEXTCH;                                                                  
00559800         END#,                                                                      
00559900                                                                                    
00560000     MAXL=                                                                          
00560100         9#,                                                                        
00560200                                                                                    
00560300     TENPOWER(J)=                                                                   
00560400         (POTL[J.[5:6]]*POTC[J.[11:6]]*POTH[J.[14:3]])#,                            
00560500                                                                                    
00560600     READNEXTCARD=                                                                  
00560700         BEGIN                                                                      
00560800           IF READNEXTLINE(CARDWBUF) THEN ERROR(4204);                              
00560900           IF LINEINFOTOG THEN LINEINFO(INSYP73);                                   
00561000           REPLACE LINENUMBERPTR BY INSYP73 FOR 8;                                  
00561100           REPLACE INSYP73 BY " ";                                                  
00561200           INSYP:=INSYP1; INSYK:=73;                                                
00561300         END#;                                                                      
00561400                                                                                    
00561500   REAL VALUE ARRAY RESWORD(                                                        
00561600  $SET OMIT = OTHERWISE                                                             
00561700         10,10,28,55,76,94,109,115,121,124,                                         
00561800  $POP OMIT                                                                         
00561900  $SET OMIT = NOT OTHERWISE                                                         
00562000         10,10,28,55,76,94,109,115,121,127,                                         
00562100  $POP OMIT                                                                         
00562200         "IF    ","      ", 4"200F",                                                
00562300         "DO    ","      ", 4"2B0F",                                                
00562400         "OF    ","      ", 4"2A0F",                                                
00562500         "TO    ","      ", 4"2C0F",                                                
00562600         "IN    ","      ", 4"070E",                                                
00562700         "OR    ","      ", 4"0607",                                                
00562800         "END   ","      ", 4"270F",                                                
00562900         "FOR   ","      ", 4"240F",                                                
00563000         "VAR   ","      ", 4"150F",                                                
00563100         "DIV   ","      ", 4"0503",                                                
00563200         "MOD   ","      ", 4"0504",                                                
00563300         "SET   ","      ", 4"190F",                                                
00563400         "AND   ","      ", 4"0502",                                                
00563500         "NOT   ","      ", 4"040F",                                                
00563600         "NEQ   ","      ", 4"070C",                                                
00563700         "THEN  ","      ", 4"2E0F",                                                
00563800  $SET OMIT = OTHERWISE                                                             
00563900         "ELSE  ","      ", 4"280F",                                                
00564000  $POP OMIT                                                                         
00564100  $SET OMIT = NOT OTHERWISE                                                         
00564200         "ELSE  ","      ", 4"2810",                                                
00564300  $POP OMIT                                                                         
00564400         "WITH  ","      ", 4"250F",                                                
00564500         "GOTO  ","      ", 4"260F",                                                
00564600         "CASE  ","      ", 4"210F",                                                
00564700         "TYPE  ","      ", 4"140F",                                                
00564800         "FILE  ","      ", 4"1D0F",                                                
00564900         "BEGIN ","      ", 4"1F0F",                                                
00565000         "UNTIL ","      ", 4"290F",                                                
00565100         "WHILE ","      ", 4"230F",                                                
00565200         "ARRAY ","      ", 4"1B0F",                                                
00565300         "CONST ","      ", 4"130F",                                                
00565400         "LABEL ","      ", 4"120F",                                                
00565500         "FORMAT","      ",4"170F",                                                 
00565600         "REPEAT","      ", 4"220F",                                                
00565700         "RECORD","      ", 4"1C0F",                                                
00565800         "DOWNTO","      ", 4"2D0F",                                                
00565900         "PACKED","      ", 4"1A0F",                                                
00566000         "FORWAR","D     ", 4"1E12",                                                
00566100         "PROGRA","M     ", 4"180F",                                                
00566200         "EXTERN","AL    ", 4"1E13",                                                
00566300         "FUNCTI","ON    ", 4"160F",                                                
00566400  $SET OMIT = NOT OTHERWISE                                                         
00566500         "OTHERW","ISE   ", 4"2811",                                                
00566600  $POP OMIT                                                                         
00566700         "PROCED","URE   ", 4"180F");                                               
00566800                                                                                    
00566900   % EXECUTABLE CODE ----------------------------------------------------           
00567000 RESCAN:                                                                            
00567100   SCAN INSYP:INSYP FOR INSYK:INSYK UNTIL NEQ " ";                                  
00567200   IF (INSYK=0) THEN BEGIN                                                          
00567300     READNEXTCARD;                                                                  
00567400     GOTO RESCAN;                                                                   
00567500   END;                                                                             
00567600   INSYSTART:=INSYK;                                                                
00567700   %                                                                                
00567800   CASE CH OF BEGIN                                                                 
00567900                                                                                    
00568000 "*":                                                                               
00568100     ITSA(MULOP,MUL);                                                               
00568200 "/":                                                                               
00568300     ITSA(MULOP,REALDIV);                                                           
00568400 "+":                                                                               
00568500     ITSA(ADDOP,PLUS);                                                              
00568600 "-":                                                                               
00568700     ITSA(ADDOP,MINUS);                                                             
00568800 "=":                                                                               
00568900     ITSA(RELOP,EQOP);                                                              
00569000 ")":                                                                               
00569100     ITSA(RPARENT,NOOPR);                                                           
00569200 "[":                                                                               
00569300     ITSA(LBRACK,NOOPR);                                                            
00569400 "]":                                                                               
00569500     ITSA(RBRACK,NOOPR);                                                            
00569600 ",":                                                                               
00569700     ITSA(COMMA,NOOPR);                                                             
00569800 ";":                                                                               
00569900     ITSA(SEMICOLON,NOOPR);                                                         
00570000 "@":                                                                               
00570100 48"5F":               %UP ARRAOW ON LA36,TI700,TELERAY                             
00570200     ITSA(ARROW,NOOPR);                                                             
00570300                                                                                    
00570400 "%":                                                                               
00570500     BEGIN                                                                          
00570600       INSYP:=INSYP73; INSYK:=1;                                                    
00570700       GOTO RESCAN;                                                                 
00570800     END;                                                                           
00570900                                                                                    
00571000 ":":                                                                               
00571100     BEGIN                                                                          
00571200       NEXTCH; OP:=NOOPR;                                                           
00571300       IF (CH = "=") THEN BEGIN                                                     
00571400         SYMBOL:=BECOMES; NEXTCH;                                                   
00571500       END ELSE BEGIN                                                               
00571600         SYMBOL:=COLON;                                                             
00571700       END;                                                                         
00571800     END;                                                                           
00571900                                                                                    
00572000 ".":                                                                               
00572100     BEGIN                                                                          
00572200       NEXTCH; OP:=NOOPR;                                                           
00572300       IF (CH = ".") THEN BEGIN                                                     
00572400         SYMBOL:=COLON; NEXTCH;                                                     
00572500       END ELSE BEGIN                                                               
00572600         SYMBOL:=PERIOD;                                                            
00572700       END;                                                                         
00572800     END;                                                                           
00572900                                                                                    
00573000 "<":                                                                               
00573100     BEGIN                                                                          
00573200       NEXTCH; SYMBOL:=RELOP;                                                       
00573300       IF (CH = "=") THEN BEGIN                                                     
00573400         OP:=LEOP; NEXTCH;                                                          
00573500       END ELSE IF (CH = ">") THEN BEGIN                                            
00573600         OP:=NEOP; NEXTCH;                                                          
00573700       END ELSE BEGIN                                                               
00573800         OP:=LTOP;                                                                  
00573900       END;                                                                         
00574000     END;                                                                           
00574100                                                                                    
00574200 ">":                                                                               
00574300     BEGIN                                                                          
00574400       NEXTCH; SYMBOL:=RELOP;                                                       
00574500       IF (CH = "=") THEN BEGIN                                                     
00574600         OP:=GEOP; NEXTCH;                                                          
00574700       END ELSE BEGIN                                                               
00574800         OP:=GTOP;                                                                  
00574900       END;                                                                         
00575000     END;                                                                           
00575100                                                                                    
00575200 "(":                                                                               
00575300     BEGIN                                                                          
00575400       NEXTCH;                                                                      
00575500       IF (CH = "*") THEN BEGIN                                                     
00575600         NEXTCH;                                                                    
00575700         IF (CH="$") THEN ERROR(6200);                                              
00575800         DO BEGIN                                                                   
00575900 COMSCAN:  SCAN INSYP:INSYP FOR INSYK:INSYK UNTIL IN SEMIASTERISK;                  
00576000           IF (INSYK=0) THEN BEGIN                                                  
00576100             READNEXTCARD;                                                          
00576200             GOTO COMSCAN;                                                          
00576300           END;                                                                     
00576400           IF(CH = ";") THEN BEGIN                                                  
00576500             INSYSTART:=INSYK;    %FUDGE TO GET * IN RIGHT PLACE                    
00576600             INSYK:=*-1;                                                            
00576700             ERROR(1213);                                                           
00576800             INSYK:=*+1;                                                            
00576900           END;                                                                     
00577000           NEXTCH;                                                                  
00577100         END UNTIL (CH = ")");                                                      
00577200         NEXTCH;                                                                    
00577300         GOTO RESCAN;                                                               
00577400       END ELSE BEGIN                                                               
00577500         SYMBOL:=LPARENT; OP:=NOOPR;                                                
00577600       END;                                                                         
00577700     END;                                                                           
00577800                                                                                    
00577900 "{": % LEFT CURLY BRACKET                                                          
00578000     BEGIN                                                                          
00578100       NEXTCH;                                                                      
00578200       IF (CH="$") THEN ERROR(6200);                                                
00578300 COM2SCAN:                                                                          
00578400       SCAN INSYP:INSYP FOR INSYK:INSYK UNTIL IN SEMICURLY;                         
00578500       IF (INSYK=0) THEN BEGIN                                                      
00578600         READNEXTCARD;                                                              
00578700         GOTO COM2SCAN;                                                             
00578800       END;                                                                         
00578900       IF (CH=";") THEN BEGIN                                                       
00579000         INSYSTART:=INSYK;   %FUDGE TO GET * IN RIGHT PLACE                         
00579100         INSYK:=*-1;                                                                
00579200         ERROR(1213);                                                               
00579300         INSYK:=*+1;                                                                
00579400         NEXTCH;                                                                    
00579500         GO TO COM2SCAN;                                                            
00579600       END;                                                                         
00579700       NEXTCH;                                                                      
00579800       GO TO RESCAN;                                                                
00579900     END;                                                                           
00580000                                                                                    
00580100 "A":"B":"C":"D":"E":"F":"G":"H":"I":"J":"K":"L":"M":                               
00580200 "N":"O":"P":"Q":"R":"S":"T":"U":"V":"W":"X":"Y":"Z":                               
00580300 "a":"b":"c":"d":"e":"f":"g":"h":"i":"j":"k":"l":"m":                               
00580400 "n":"o":"p":"q":"r":"s":"t":"u":"v":"w":"x":"y":"z":                               
00580500     BEGIN                                                                          
00580600       SCAN INSYP FOR INSYE:INSYK UNTIL IN NOTALPHANUM;                             
00580700       REPLACE INSYN BY INSYP:INSYP FOR                                             
00580800         (LENGTH:=INSYK-INSYE) WITH LCTOUC,                                         
00580900         " ";                                                                       
00581000       IF (LENGTH <= MAXL) THEN BEGIN                                               
00581100         % MAY BE A RESERVED WORD                                                   
00581200         INSYSCAN:=RESWORD[LENGTH-1];                                               
00581300         WHILE (INSYSCAN < RESWORD[LENGTH]) DO BEGIN                                
00581400           IF (POINTER(RESWORD[INSYSCAN]) = INSYN FOR LENGTH)                       
00581500             THEN BEGIN                                                             
00581600             % IT IS A RESERVED WORD                                                
00581700             SYMBOL:=RESWORD[INSYSCAN+2].[15:8];                                    
00581800             OP    :=RESWORD[INSYSCAN+2].[07:8];                                    
00581900             GOTO WASRESERVEDWORD;                                                  
00582000           END ELSE BEGIN                                                           
00582100             % SO KEEP LOOKING MATE                                                 
00582200             INSYSCAN:=INSYSCAN+3;                                                  
00582300           END; % OF IF                                                             
00582400         END; % OF WHILE                                                            
00582500       END; % OF IF LENGTH                                                          
00582600       SYMBOL:=IDENT; OP:=NOOPR;                                                    
00582700       NAMEBUF[0].[47:8]:=(LENGTH:=LENGTH+1);                                       
00582800 WASRESERVEDWORD:                                                                   
00582900       INSYK:=INSYE;                                                                
00583000     END; % OF A-Z                                                                  
00583100                                                                                    
00583200 "0":"1":"2":"3":"4":"5":"6":"7":"8":"9":                                           
00583300     BEGIN                                                                          
00583400       SCAN INSYP FOR INSYE:INSYK UNTIL IN NONDIGITS;                               
00583500       LENGTH:=INSYK-INSYE;                                                         
00583600       IF (LENGTH <= 12) THEN BEGIN                                                 
00583700         VAL:=INTEGER(INSYP,LENGTH);                                                
00583800         INSYP:=INSYP+LENGTH; INSYK:=INSYE;                                         
00583900       END ELSE BEGIN                                                               
00584000         VAL:=0;                                                                    
00584100         INSYP:=INSYP+LENGTH; INSYK:=INSYE;                                         
00584200         ERROR(2200);                                                               
00584300       END;                                                                         
00584400       SYMBOL:=INTCONST; OP:=NOOPR;                                                 
00584500       IF ((CH=".") AND (INSYP NEQ ".." FOR 2)) OR (CH="E") OR (CH="e")             
00584600         THEN BEGIN                                                                 
00584700         DNUMBER:=0; EXPONENT:=0;                                                   
00584800         % PROCESS A POSSIBLE FRACTIONAL PART                                       
00584900         % ----------------------------------                                       
00585000         IF (CH = ".") THEN BEGIN                                                   
00585100           NEXTCH;                                                                  
00585200           IF (CH >= "0") AND (CH <= "9") THEN BEGIN                                
00585300             SCAN INSYP FOR INSYE:INSYK UNTIL IN NONDIGITS;                         
00585400             LENGTH:=INSYK-INSYE;                                                   
00585500             IF (LENGTH <= 23) THEN BEGIN                                           
00585600               DNUMBER:=DOUBLE(INSYP,LENGTH);                                       
00585700               EXPONENT:=LENGTH;                                                    
00585800             END ELSE BEGIN                                                         
00585900               DNUMBER:=DOUBLE(INSYP,23);                                           
00586000               EXPONENT:=23;                                                        
00586100             END; % OF IF LENGTH <= 23                                              
00586200             DNUMBER:= VAL + (DNUMBER / TENPOWER(EXPONENT));                        
00586300             INSYP:=INSYP+LENGTH; INSYK:=INSYE;                                     
00586400           END ELSE BEGIN                                                           
00586500             ERROR(2204);                    % NO FRACTION DIGIT                    
00586600           END;                                                                     
00586700         END ELSE BEGIN                                                             
00586800           DNUMBER := VAL;                                                          
00586900         END; % OF FRACTION PROCESSING                                              
00587000                                                                                    
00587100         % PROCESS A POSSIBLE EXPONENT PART                                         
00587200         % --------------------------------                                         
00587300         IF (CH = "E") OR (CH = "e") THEN BEGIN                                     
00587400           NEXTCH;                                                                  
00587500           EXPONENT:=0;                                                             
00587600           IF (CH = "-") THEN BEGIN                                                 
00587700             POSITIVE:=FALSE;                                                       
00587800             NEXTCH;                                                                
00587900           END ELSE BEGIN                                                           
00588000             POSITIVE:=TRUE;                                                        
00588100             IF (CH = "+") THEN NEXTCH;                                             
00588200           END; % OF IF ON SIGN CHARACTER                                           
00588300           IF (CH >= "0") AND (CH <= "9") THEN BEGIN                                
00588400             SCAN INSYP FOR INSYE:INSYK UNTIL IN NONDIGITS;                         
00588500             LENGTH:=INSYK-INSYE;                                                   
00588600             IF (LENGTH <= 3) THEN BEGIN                                            
00588700               EXPONENT:=INTEGER(INSYP,LENGTH);                                     
00588800             END ELSE BEGIN                                                         
00588900               ERROR(2205);                  % TOO MANY EXPONENT DIGITS             
00589000             END;                                                                   
00589100             INSYP:=INSYP+LENGTH;  INSYK:=INSYE;                                    
00589200           END ELSE BEGIN                                                           
00589300             ERROR(2206);                    % NO EXPONENT DIGITS                   
00589400           END;                                                                     
00589500           IF POSITIVE THEN BEGIN                                                   
00589600             DNUMBER:= DNUMBER * TENPOWER(EXPONENT);                                
00589700           END ELSE BEGIN                                                           
00589800             DNUMBER:= DNUMBER / TENPOWER(EXPONENT);                                
00589900           END;                                                                     
00590000         END; % OF EXPONENT PROCESSING                                              
00590100                                                                                    
00590200         % ACQUIRE SINGLE-PRECISION REAL NUMBER                                     
00590300         % ------------------------------------                                     
00590400         IF (DNUMBER < 3"1771000000000000")                                         
00590500         OR (DNUMBER > 3"0777777777777777") THEN BEGIN                              
00590600           IF (DNUMBER NEQ 0) THEN ERROR(2207);      % UNREPRESENTABLE              
00590700           VAL:=0;                                                                  
00590800         END ELSE BEGIN                                                             
00590900           VAL:=REAL(DNUMBER);                                                      
00591000         END;                                                                       
00591100         SYMBOL:=REALCONST;                                                         
00591200       END;                                                                         
00591300     END; % OF 0-9                                                                  
00591400                                                                                    
00591500 """: "'":                                                                          
00591600     BEGIN                                                                          
00591700       INSYSCAN:=CH;                                                                
00591800       INSYN1 := INSYN;                                                             
00591900       LENGTH := 0;                                                                 
00592000       DO BEGIN                                                                     
00592100         NEXTCH;                                                                    
00592200         INSYE := INSYK;                                                            
00592300         REPLACE INSYN1:INSYN1 BY INSYP:INSYP FOR INSYK:INSYK                       
00592400           UNTIL = INSYSCAN;                                                        
00592500         LENGTH := * + (INSYE - INSYK);                                             
00592600         IF (INSYK > 0) THEN BEGIN                                                  
00592700           NEXTCH;                                                                  
00592800           IF (CH = INSYSCAN) THEN BEGIN                                            
00592900             REPLACE INSYN1:INSYN1 BY INSYP FOR 1;                                  
00593000             LENGTH := *+1;                                                         
00593100           END;                                                                     
00593200         END;                                                                       
00593300       END UNTIL ((CH NEQ INSYSCAN) OR (INSYK <= 0));                               
00593400       IF ASCIITOG THEN BEGIN                                                       
00593500         REPLACE INSYN BY INSYN FOR LENGTH WITH EBCDICTOASCII;                      
00593600       END;                                                                         
00593700       IF (INSYK=0) THEN BEGIN                                                      
00593800         ERROR(2201);                                                               
00593900         VAL:="?"; INSYK:=0; LENGTH:=1;                                             
00594000       END ELSE BEGIN                                                               
00594100         IF (LENGTH=1) THEN BEGIN                                                   
00594200           VAL:=REAL(INSYN,1);                                                      
00594300         END ELSE IF (LENGTH = 0) THEN BEGIN                                        
00594400           VAL:="?";                                                                
00594500           ERROR(2202);                                                             
00594600           LENGTH:=1;                                                               
00594700         END ELSE BEGIN                                                             
00594800           VAL:=INSERTINTOPOOL(INSYN,LENGTH);                                       
00594900         END;                                                                       
00595000       END; % OF IF TOGGLE                                                          
00595100       SYMBOL:=STRINGCONST; OP:=NOOPR;                                              
00595200     END; % OF STRINGS                                                              
00595300                                                                                    
00595400 "}": % RIGHT CURLY BRACKET                                                         
00595500     BEGIN                                                                          
00595600       ITSA(OTHERSY,NOOPR);                                                         
00595700       ERROR(2208);                                                                 
00595800     END;                                                                           
00595900                                                                                    
00596000   ELSE: % OF CASE                                                                  
00596100     BEGIN                                                                          
00596200       ITSA(OTHERSY,NOOPR);                                                         
00596300       ERROR(2203);                                                                 
00596400     END; % OF ALL OTHER CHARACTERS                                                 
00596500                                                                                    
00596600   END; % OF CASE                                                                   
00596700 END; % OF INSYMBOL                                                                 
00596800                                                                                    
00596900 PROCEDURE SKIP(FSYMBOLSET);                                                        
00597000 %         ****                                                                     
00597100 VALUE FSYMBOLSET;                                                                  
00597200 TYPESETOFSYS FSYMBOLSET;                                                           
00597300 BEGIN                                                                              
00597400   INTEGER IGNOREDSYMBOLS;                                                          
00597500   %                                                                                
00597600   IGNOREDSYMBOLS:=0;                                                               
00597700   WHILE NOT SYMBOLIN(FSYMBOLSET) DO BEGIN                                          
00597800     INSYMBOL; IGNOREDSYMBOLS:=IGNOREDSYMBOLS+1;                                    
00597900   END;                                                                             
00598000   IF LISTTOG AND (IGNOREDSYMBOLS > 1) THEN BEGIN                                   
00598100     REPLACE LBUF0 BY "TEXT IGNORED TO",                                            
00598200                      "-" FOR (73-INSYSTART), ":";                                  
00598300     WRITE(LINE,22,LBUF[*]);                                                        
00598400     REPLACE LBUF0 BY " " FOR 22 WORDS;                                             
00598500   END;                                                                             
00598600 END; % OF SKIP                                                                     
00598700                                                                                    
00598800                                                                                    
00598900 %=======================================================================           
00599000 %                                                                                  
00599100 % PROCEDURES TO HANDLE SYMBOL TABLE AND STRUCTURE TABLE                            
00599200 %                                                                                  
00599300 %=======================================================================           
00599400                                                                                    
00599500 PROCEDURE ENTERID(IDENTPTR);                                                       
00599600 %         *******                                                                  
00599700 VALUE IDENTPTR;                                                                    
00599800 TYPEIDENTPTR IDENTPTR;                                                             
00599900 BEGIN                                                                              
00600000   TYPEIDENTPTR LIP,LIPFOLLOWER,LTOP;                                               
00600100   BOOLEAN LLEFT,LONGNAME;                                                          
00600200   POINTER P,NAMEPTR;                                                               
00600300   INTEGER L,LENG,CASENO;                                                           
00600400   EBCDIC ARRAY LNAME [0:7];                                                        
00600500   DEFINE                                                                           
00600600     NOCASE=0#,                                                                     
00600700     DUPLICATE=1#,                                                                  
00600800     DUPSHORT=2#;                                                                   
00600900                                                                                    
00601000   NAMEPTR := POINTER(HEAP[NAME(IDENTPTR)]);                                        
00601100   LENG := REAL(NAMEPTR,1);                                                         
00601200   NAMEPTR := *+1;                                                                  
00601300   IF STANDARDTOG THEN BEGIN                                                        
00601400     LTOP:=TOP;                                                                     
00601500     IF (LONGNAME:=(LENG>9)) THEN BEGIN                                             
00601600       REPLACE LNAME BY NAMEPTR FOR 8;                                              
00601700     END;                                                                           
00601800     CASENO:=NOCASE;                                                                
00601900     WHILE (LTOP>0) AND (CASENO=NOCASE) DO BEGIN                                    
00602000       LIP:=FNAME(LTOP);                                                            
00602100       WHILE ((LIP NEQ NIL) AND (CASENO=NOCASE)) DO BEGIN                           
00602200         P:=POINTER(HEAP[NAME(LIP)]);                                               
00602300         L:=MIN(REAL(P,1),LENG);                                                    
00602400         P:=P+1;                                                                    
00602500         IF (P<=NAMEPTR FOR L) THEN BEGIN                                           
00602600           IF (P=NAMEPTR FOR L) THEN BEGIN                                          
00602700             CASENO:=DUPLICATE;                                                     
00602800           END ELSE BEGIN                                                           
00602900             IF LONGNAME THEN BEGIN                                                 
00603000               IF(P=LNAME FOR 8) THEN BEGIN                                         
00603100                 CASENO:=DUPSHORT;                                                  
00603200               END;                                                                 
00603300             END;                                                                   
00603400           END;                                                                     
00603500           LIP:=RLINK(LIP);                                                         
00603600         END ELSE BEGIN                                                             
00603700           IF LONGNAME THEN BEGIN                                                   
00603800             IF(P=LNAME FOR 8) THEN BEGIN                                           
00603900               CASENO:=DUPSHORT;                                                    
00604000             END;                                                                   
00604100           END;                                                                     
00604200           LIP:=LLINK(LIP);                                                         
00604300         END;                                                                       
00604400       END;     %OF WHILE                                                           
00604500       IF (CASENO=NOCASE) THEN LTOP:=*-1;                                           
00604600     END;    %OF WHILE                                                              
00604700     IF (LTOP>0) THEN BEGIN           %DUP FOUND                                    
00604800       IF (LTOP=TOP) THEN BEGIN       %AT TOP LEVEL                                 
00604900         IF (CASENO=DUPSHORT) THEN BEGIN                                            
00605000           ERROR(1211);           %WARN-NOT UNIQUE OVER 1ST 8 CHAR                  
00605100         END;         %IGNORE ERROR CASE;                                           
00605200       END ELSE BEGIN                                                               
00605300         IF (CASENO=DUPLICATE) THEN BEGIN                                           
00605400           ERROR(6213);        %NOTE - REDEFINITION                                 
00605500         END ELSE BEGIN                                                             
00605600           ERROR(1212);        %WARN - NAME CLASH OVER 1ST 8 CHAR OTHER L           
00605700         END;                                                                       
00605800       END;       %OF IF (LTOP=TOP)                                                 
00605900     END;      %OF IF (LTOP>0)                                                      
00606000   END;      %OF IF STANDARDTOG                                                     
00606100   LIP:=FNAME(TOP);                                                                 
00606200   IF (LIP = NIL) THEN BEGIN                                                        
00606300     FNAME(TOP):=IDENTPTR;                                                          
00606400   END ELSE BEGIN                                                                   
00606500     DO BEGIN                                                                       
00606600       LIPFOLLOWER:=LIP;                                                            
00606700       P:=POINTER(HEAP[NAME(LIP)]); L:=MIN(REAL(P,1),LENG);                         
00606800       P:=P+1;                                                                      
00606900       IF (P <= NAMEPTR FOR L) THEN BEGIN                                           
00607000         IF (P = NAMEPTR FOR L) THEN BEGIN                                          
00607100           ERROR(2210);                                                             
00607200         END;                                                                       
00607300         LIP:=RLINK(LIP); LLEFT:=FALSE;                                             
00607400       END ELSE BEGIN                                                               
00607500         LIP:=LLINK(LIP); LLEFT:=TRUE;                                              
00607600       END; % OF IF                                                                 
00607700     END UNTIL (LIP = NIL);                                                         
00607800     IF LLEFT THEN BEGIN                                                            
00607900       LLINK(LIPFOLLOWER):=IDENTPTR;                                                
00608000     END ELSE BEGIN                                                                 
00608100       RLINK(LIPFOLLOWER):=IDENTPTR;                                                
00608200     END;                                                                           
00608300   END;                                                                             
00608400   LLINK(IDENTPTR):=NIL;                                                            
00608500   RLINK(IDENTPTR):=NIL;                                                            
00608600 END; % OF ENTER IDENTIFIER                                                         
00608700                                                                                    
00608800 PROCEDURE SEARCHSECTION(STARTPTR,PTR);                                             
00608900 %         *************                                                            
00609000 VALUE STARTPTR;                                                                    
00609100 TYPEIDENTPTR STARTPTR,PTR;                                                         
00609200 BEGIN                                                                              
00609300   POINTER P;                                                                       
00609400   INTEGER L;                                                                       
00609500   LABEL EXIT;                                                                      
00609600                                                                                    
00609700   WHILE (STARTPTR NEQ NIL) DO BEGIN                                                
00609800     P:=POINTER(HEAP[NAME(STARTPTR)]);                                              
00609900     L:=MIN(REAL(P,1),LENGTH);                                                      
00610000     P:=P+1;                                                                        
00610100     IF (P = NAMEBUF1 FOR L) THEN BEGIN                                             
00610200       GOTO EXIT;                                                                   
00610300     END ELSE IF (P < NAMEBUF1 FOR L) THEN BEGIN                                    
00610400       STARTPTR:=RLINK(STARTPTR);                                                   
00610500     END ELSE BEGIN                                                                 
00610600       STARTPTR:=LLINK(STARTPTR);                                                   
00610700     END; % OF IF                                                                   
00610800   END; % OF WHILE                                                                  
00610900 EXIT:                                                                              
00611000   PTR:=STARTPTR;                                                                   
00611100 END; % OF SEARCH SECTION                                                           
00611200                                                                                    
00611300 PROCEDURE SEARCHID(IDENTCLASS,IDENTPTR);                                           
00611400 %         ********                                                                 
00611500 VALUE IDENTCLASS;                                                                  
00611600 TYPESETOFIDS IDENTCLASS;                                                           
00611700 TYPEIDENTPTR IDENTPTR;                                                             
00611800 BEGIN                                                                              
00611900   LABEL EXIT;                                                                      
00612000   POINTER P;                                                                       
00612100   INTEGER L;                                                                       
00612200   TYPEIDENTPTR PTR;                                                                
00612300   %                                                                                
00612400   FOR DISX:=TOP DOWNTO 0 DO BEGIN                                                  
00612500     PTR:=FNAME(DISX);                                                              
00612600     WHILE (PTR NEQ NIL) DO BEGIN                                                   
00612700       P:=POINTER(HEAP[NAME(PTR)]);                                                 
00612800       L:=MIN(REAL(P,1),LENGTH);                                                    
00612900       P:=P+1;                                                                      
00613000       IF (P <= NAMEBUF1 FOR L) THEN BEGIN                                          
00613100         IF (P = NAMEBUF1 FOR L) THEN BEGIN                                         
00613200           IF INTEST(KLASS(PTR),IDENTCLASS) THEN BEGIN                              
00613300             GOTO EXIT;                                                             
00613400           END ELSE BEGIN                                                           
00613500             IF PRTERR THEN ERROR(2220);                                            
00613600           END;                                                                     
00613700         END;                                                                       
00613800         PTR:=RLINK(PTR);                                                           
00613900       END ELSE BEGIN                                                               
00614000         PTR:=LLINK(PTR);                                                           
00614100       END; % OF IF P                                                               
00614200     END; % OF WHILE                                                                
00614300   END; % OF FOR                                                                    
00614400   % SEARCH WAS NOT SUCCESSFUL                                                      
00614500   %   DO NOT GIVE ERROR FOR FORWARD REFCING POINTER,                               
00614600   %   AND RETURN AN UNDECLARED POINTER RATHER THAN NIL.                            
00614700   DISX:=0;                                                                         
00614800   IF PRTERR THEN BEGIN                                                             
00614900     ERROR(2221);                                                                   
00615000     IF INTEST(TYPES,IDENTCLASS) THEN PTR:=UTYPPTR                                  
00615100     ELSE IF INTEST(VARS,IDENTCLASS) THEN PTR:=UVARPTR                              
00615200     ELSE IF INTEST(FIELD,IDENTCLASS) THEN PTR:=UFLDPTR                             
00615300     ELSE IF INTEST(KONST,IDENTCLASS) THEN PTR:=UCSTPTR                             
00615400     ELSE IF INTEST(PROC,IDENTCLASS) THEN PTR:=UPRCPTR                              
00615500     ELSE PTR:=UFCTPTR;                                                             
00615600   END; % OF IF                                                                     
00615700 EXIT:                                                                              
00615800   IDENTPTR:=PTR;                                                                   
00615900 END; % OF SEARCH IDENTIFIER                                                        
00616000                                                                                    
00616100 PROCEDURE GETBOUNDS(FSP,FMIN,FMAX);                                                
00616200 %         *********                                                                
00616300 VALUE FSP;                                                                         
00616400 TYPESTRUCTPTR FSP;                                                                 
00616500 INTEGER FMIN,FMAX;                                                                 
00616600 BEGIN                                                                              
00616700   LABEL FORCESEGMENTATION;                                                         
00616800   IF (FORM(FSP) = SUBRANGE) THEN BEGIN                                             
00616900     FMIN:=SMIN(FSP);                                                               
00617000     FMAX:=SMAX(FSP);                                                               
00617100   END ELSE BEGIN                                                                   
00617200     FMIN:=0;                                                                       
00617300     IF (FSP = CHARPTR) THEN BEGIN                                                  
00617400       FMAX:=IF ASCIITOG THEN 127 ELSE 255;                                         
00617500     END ELSE IF (FCONST(FSP) NEQ NIL) THEN BEGIN                                   
00617600       FMAX:=VALUES(FCONST(FSP));                                                   
00617700     END ELSE BEGIN                                                                 
00617800       FMAX:=0;                                                                     
00617900     END;                                                                           
00618000   END;                                                                             
00618100 END; % OF GET BOUNDS                                                               
00618200                                                                                    
00618300                                                                                    
00618400 PROCEDURE NEWTEMPVAR(FIP);                                                         
00618500 %         **********                                                               
00618600 TYPEIDENTPTR FIP;                                                                  
00618700 BEGIN                                                                              
00618800   NEW(FIP,OTHERIDENTSIZE+1);                                                       
00618900   HEAP[FIP+OTHERIDENTSIZE]:=0;                                                     
00619000   NAME(FIP):=FIP+OTHERIDENTSIZE;                                                   
00619100   IDTYPE(FIP):=REALPTR;                                                            
00619200   VKIND(FIP):=ACTUAL;                                                              
00619300   KLASS(FIP):=VARS;                                                                
00619400 END;   %OF NEWTEMPVAR                                                              
00619500                                                                                    
00619600 PROCEDURE NEWTEMPSET(FIP);                                                         
00619700 %         **********                                                               
00619800 TYPEIDENTPTR FIP;                                                                  
00619900 BEGIN                                                                              
00620000   NEW(FIP,OTHERIDENTSIZE+1);                                                       
00620100   HEAP[FIP+OTHERIDENTSIZE]:=0;                                                     
00620200   NAME(FIP):=FIP+OTHERIDENTSIZE;                                                   
00620300   IDTYPE(FIP):=NIL;                                                                
00620400   VKIND(FIP):=ACTUAL;                                                              
00620500   KLASS(FIP):=VARS;                                                                
00620600 END;   %OF NEWTEMPSET                                                              
00620700                                                                                    
00620800 PROCEDURE NEWTEMPARR(FIP);                                                         
00620900 %         **********                                                               
00621000 TYPEIDENTPTR FIP;                                                                  
00621100 BEGIN                                                                              
00621200 TYPESTRUCTPTR LSP;                                                                 
00621300   NEWTEMPVAR(FIP);                                                                 
00621400   NEW(LSP,OTHERSTRUCTSIZE);                                                        
00621500   FORM(LSP):=ARRAYS;                                                               
00621600   BITS(LSP):=BITSPERWORD;                                                          
00621700   IDTYPE(FIP):=LSP;                                                                
00621800 END;   %OF NEWTEMPARR                                                              
00621900                                                                                    
00622000 PROCEDURE BLOCK(FSYS,FSY,FPROCP,ENTRYPOINT,LC,STATISTICSFLAG,                      
00622100 %         *****                                                                    
00622200                 SDISP);                                                            
00622300 VALUE FSYS,FSY,FPROCP,LC,STATISTICSFLAG,SDISP;                                     
00622400 TYPESETOFSYS FSYS;                                                                 
00622500 TYPESYMBOL FSY;                                                                    
00622600 TYPEIDENTPTR FPROCP;                                                               
00622700 INTEGER ENTRYPOINT,LC,SDISP;                                                       
00622800 BOOLEAN STATISTICSFLAG;                                                            
00622900 BEGIN                                                                              
00623000   TYPESYMBOL LSY;                                                                  
00623100   TYPEIDENTPTR LCP,LCP1;                                                           
00623200   BOOLEAN TEST,TAGSIXFLAG;                                                         
00623300   INTEGER STACKHEADP,STACKTAILP,LCMAX,DECLAREDLC,ENTRYLC;                          
00623400                                                                                    
00623500                                                                                    
00623600 PROCEDURE PRINTTABLES(ALLFLAG);                                                    
00623700 %         ***********                                                              
00623800 VALUE ALLFLAG;                                                                     
00623900 BOOLEAN ALLFLAG;                                                                   
00624000 BEGIN                                                                              
00624100   INTEGER I,LOWLIMIT,VAL,ND,L;                                                     
00624200   EBCDIC ARRAY IDBUF[0:131];                                                       
00624300   POINTER NAMEPTR,ID0,ID9,ID21,ID28,P;                                             
00624400                                                                                    
00624500                                                                                    
00624600 PROCEDURE WRITEID;                                                                 
00624700 %         *******                                                                  
00624800 BEGIN                                                                              
00624900   WRITE(LINE,22,IDBUF[*]);                                                         
00625000   REPLACE ID0 BY " " FOR 22 WORDS;                                                 
00625100 END;                                                                               
00625200                                                                                    
00625300                                                                                    
00625400 PROCEDURE MARKCTP(FP);                                                             
00625500 VALUE FP;                                                                          
00625600 TYPEIDENTPTR FP;                                                                   
00625700   FORWARD;                                                                         
00625800                                                                                    
00625900                                                                                    
00626000 PROCEDURE MARKSTP(FP);                                                             
00626100 %         *******                                                                  
00626200 VALUE FP;                                                                          
00626300 TYPESTRUCTPTR FP;                                                                  
00626400 BEGIN                                                                              
00626500   IF (FP NEQ NIL) THEN BEGIN                                                       
00626600     MARKED(FP):=REAL(TRUE);                                                        
00626700     CASE FORM(FP) OF BEGIN                                                         
00626800       %                                                                            
00626900     SCALAR:                                                                        
00627000       ;                                                                            
00627100     SUBRANGE:                                                                      
00627200       MARKSTP(RANGETYPE(FP));                                                      
00627300     POINTERS:                                                                      
00627400       ;                                                                            
00627500     POWER:                                                                         
00627600       MARKSTP(ELSET(FP));                                                          
00627700     ARRAYS:                                                                        
00627800       MARKSTP(ELTYPE(FP));                                                         
00627900       MARKSTP(INXTYPE(FP));                                                        
00628000     RECORDS:                                                                       
00628100       MARKCTP(FSTFLD(FP));                                                         
00628200       MARKSTP(RECVAR(FP));                                                         
00628300     FILES:                                                                         
00628400       MARKSTP(FILTYPE(FP));                                                        
00628500     TAGFLD:                                                                        
00628600       MARKSTP(FSTVAR(FP));                                                         
00628700     VARIANT:                                                                       
00628800       MARKSTP(NXTVAR(FP));                                                         
00628900       MARKSTP(SUBVAR(FP));                                                         
00629000       %                                                                            
00629100     END; % OF CASE                                                                 
00629200   END; % OF IF                                                                     
00629300 END; % OF MARKSTP                                                                  
00629400                                                                                    
00629500                                                                                    
00629600 PROCEDURE MARKCTP(FP);                                                             
00629700 %         *******                                                                  
00629800 VALUE FP;                                                                          
00629900 TYPEIDENTPTR FP;                                                                   
00630000 BEGIN                                                                              
00630100   IF (FP NEQ NIL) THEN BEGIN                                                       
00630200     MARKCTP(LLINK(FP));                                                            
00630300     MARKCTP(RLINK(FP));                                                            
00630400     MARKSTP(IDTYPE(FP));                                                           
00630500   END;                                                                             
00630600 END; % OF MARKCTP                                                                  
00630700                                                                                    
00630800                                                                                    
00630900                                                                                    
00631000 PROCEDURE FOLLOWCTP(FP);                                                           
00631100 VALUE FP;                                                                          
00631200 TYPEIDENTPTR FP;                                                                   
00631300   FORWARD;                                                                         
00631400                                                                                    
00631500                                                                                    
00631600 PROCEDURE FOLLOWSTP(FP);                                                           
00631700 %         *********                                                                
00631800 VALUE FP;                                                                          
00631900 TYPESTRUCTPTR FP;                                                                  
00632000 BEGIN                                                                              
00632100                                                                                    
00632200   IF (FP NEQ NIL) THEN BEGIN                                                       
00632300     IF BOOLEAN(MARKED(FP)) THEN BEGIN                                              
00632400       MARKED(FP):=REAL(FALSE);                                                     
00632500       CASE FORM(FP) OF BEGIN                                                       
00632600         %                                                                          
00632700       SCALAR:                                                                      
00632800       SUBRANGE:                                                                    
00632900       POINTERS:                                                                    
00633000       POWER:                                                                       
00633100         ;                                                                          
00633200       ARRAYS:                                                                      
00633300         FOLLOWSTP(AELTYPE(FP));                                                    
00633400       RECORDS:                                                                     
00633500         NAMEPTR:=NAMEPTR+2;                                                        
00633600         FOLLOWCTP(FSTFLD(FP));                                                     
00633700         NAMEPTR:=NAMEPTR-2;                                                        
00633800         FOLLOWSTP(RECVAR(FP));                                                     
00633900       FILES:                                                                       
00634000         FOLLOWSTP(FILTYPE(FP));                                                    
00634100       TAGFLD:                                                                      
00634200         FOLLOWSTP(FSTVAR(FP));                                                     
00634300       VARIANT:                                                                     
00634400         FOLLOWSTP(NXTVAR(FP));                                                     
00634500         FOLLOWSTP(SUBVAR(FP));                                                     
00634600         %                                                                          
00634700       END; % OF CASE                                                               
00634800     END; % OF IF MARKED                                                            
00634900   END; % OF IF NIL                                                                 
00635000 END; % OF FOLLOWSTP                                                                
00635100                                                                                    
00635200                                                                                    
00635300 PROCEDURE FOLLOWCTP(FP);                                                           
00635400 %         *********                                                                
00635500 VALUE FP;                                                                          
00635600 TYPEIDENTPTR FP;                                                                   
00635700 BEGIN                                                                              
00635800   IF (FP NEQ NIL) THEN BEGIN                                                       
00635900                                                                                    
00636000     FOLLOWCTP(LLINK(FP));                                                          
00636100                                                                                    
00636200     P:=POINTER(HEAP[NAME(FP)]);                                                    
00636300     L:=REAL(P,1);                                                                  
00636400     P:=P+1;                                                                        
00636500     REPLACE NAMEPTR BY P FOR L;                                                    
00636600     CASE KLASS(FP) OF BEGIN                                                        
00636700                                                                                    
00636800     KONST:                                                                         
00636900       REPLACE ID28 BY "CONSTANT";                                                  
00637000                                                                                    
00637100     FIELD:                                                                         
00637200       REPLACE ID28 BY "FIELD";                                                     
00637300       VAL:=FLDADDR(FP); ND:=DIGITSIN(VAL);                                         
00637400       REPLACE P:ID0 BY " " FOR 1,                                                  
00637500                      VAL FOR ND DIGITS;                                            
00637600       IF (PACKEDFIELD(FP)=PACKEDSTRUC) THEN BEGIN                                  
00637700         IF((BITADDR(FP) NEQ 0) AND (BITRANGE(FP) NEQ 0)) THEN BEGIN                
00637800           IF (BITRANGE(FP) NEQ BITSPERWORD) THEN BEGIN                             
00637900             REPLACE P BY                                                           
00638000               ".[", BITADDR(FP) FOR 2 DIGITS,                                      
00638100               ":", BITRANGE(FP) FOR 2 DIGITS,                                      
00638200               "]";                                                                 
00638300           END;                                                                     
00638400         END;                                                                       
00638500       END;                                                                         
00638600                                                                                    
00638700     TYPES:                                                                         
00638800       REPLACE ID28 BY "TYPE";                                                      
00638900                                                                                    
00639000     VARS:                                                                          
00639100       REPLACE ID28 BY "VAR";                                                       
00639200       IF (VKIND(FP) = FORMAL) THEN BEGIN                                           
00639300         REPLACE ID21 BY "REF TO";                                                  
00639400       END;                                                                         
00639500       REPLACE ID9 BY "(",                                                          
00639600                      VLEV(FP) FOR 2 DIGITS,                                        
00639700                      ",",                                                          
00639800                      VADDR(FP) FOR 5 DIGITS,                                       
00639900                      ")";                                                          
00640000                                                                                    
00640100     PROC: FUNC:                                                                    
00640200       IF (KLASS(FP) = PROC) THEN BEGIN                                             
00640300         REPLACE ID28 BY "PROCEDURE";                                               
00640400       END ELSE BEGIN                                                               
00640500         REPLACE ID28 BY "FUNCTION";                                                
00640600       END;                                                                         
00640700       IF (PFKIND(FP) = FORMAL) THEN BEGIN                                          
00640800         REPLACE ID21 BY "FORMAL";                                                  
00640900       END;                                                                         
00641000       REPLACE ID9 BY "(",                                                          
00641100                      PFLEV(FP) FOR 2 DIGITS,                                       
00641200                      ",",                                                          
00641300                      PFDPLMT(FP) FOR 5 DIGITS,                                     
00641400                      ")";                                                          
00641500                                                                                    
00641600       FORMATS:                                                                     
00641700         REPLACE ID28 BY "FORMAT";                                                  
00641800                                                                                    
00641900     END; % OF CASE                                                                 
00642000     WRITEID;                                                                       
00642100                                                                                    
00642200     FOLLOWSTP(IDTYPE(FP));                                                         
00642300                                                                                    
00642400     FOLLOWCTP(RLINK(FP));                                                          
00642500                                                                                    
00642600   END;                                                                             
00642700 END; % OF FOLLOWCTP                                                                
00642800                                                                                    
00642900                                                                                    
00643000   % BODY OF PRINTTABLES                                                            
00643100   %         ***********                                                            
00643200   IF (FNAME(TOP) NEQ NIL) THEN                                                     
00643300   BEGIN                                                                            
00643400     ID0:= IDBUF[00];                                                               
00643500     ID9:= IDBUF[09];                                                               
00643600     ID21:=IDBUF[21];                                                               
00643700     ID28:=IDBUF[28];                                                               
00643800     NAMEPTR:=IDBUF[41];                                                            
00643900     REPLACE ID0 BY " " FOR 22 WORDS;                                               
00644000     WRITEID;                                                                       
00644100     REPLACE ID0 BY "NAME TABLE DECLARED AT THIS LEVEL",                            
00644200                    " (WITH ACCESSED RECORDS)";                                     
00644300     WRITEID;                                                                       
00644400     REPLACE ID0 BY "=" FOR 57;                                                     
00644500     WRITEID;                                                                       
00644600     REPLACE ID0 BY " FIELD       STACK     NAME-TYPE         NAME";                
00644700     WRITEID;                                                                       
00644800     REPLACE ID0 BY "ADDRESS   LOCATION";                                           
00644900     WRITEID;                                                                       
00645000     WRITEID;                                                                       
00645100     LOWLIMIT:=(IF ALLFLAG THEN 0 ELSE TOP);                                        
00645200     FOR I:=TOP DOWNTO LOWLIMIT DO BEGIN                                            
00645300       MARKCTP(FNAME(I));                                                           
00645400     END;                                                                           
00645500     FOR I:=TOP DOWNTO LOWLIMIT DO BEGIN                                            
00645600       FOLLOWCTP(FNAME(I));                                                         
00645700     END;                                                                           
00645800     WRITEID;                                                                       
00645900   END;                                                                             
00646000 END; % OF PRINT TABLES                                                             
00646100                                                                                    
00646200 % END OF PRINT TABLES PACKAGE ******************************************           
00646300                                                                                    
00646400                                                                                    
00646500 PROCEDURE CONSTANT(FSYMBOLSET,FSP,FVALUE);                                         
00646600 %         ********                                                                 
00646700 VALUE FSYMBOLSET;                                                                  
00646800 TYPESETOFSYS FSYMBOLSET;                                                           
00646900 TYPESTRUCTPTR FSP;                                                                 
00647000 REAL FVALUE;                                                                       
00647100 BEGIN                                                                              
00647200   TYPESTRUCTPTR LSP,LSP1;                                                          
00647300   TYPEIDENTPTR LIP;                                                                
00647400   INTEGER SIGN;                                                                    
00647500                                                                                    
00647600   DEFINE NONE=0#, POS=1#, NEG=2#;                                                  
00647700                                                                                    
00647800   LSP:=NIL; FVALUE:=0;                                                             
00647900   IF NOT SYMBOLIN(CONSTBEGSYS) THEN BEGIN                                          
00648000     ERROR(2340);                                                                   
00648100     SKIP(FSYMBOLSET OR CONSTBEGSYS);                                               
00648200   END;                                                                             
00648300   IF SYMBOLIN(CONSTBEGSYS) THEN BEGIN                                              
00648400     IF (SYMBOL = STRINGCONST) THEN BEGIN                                           
00648500       IF (LENGTH = 1) THEN BEGIN                                                   
00648600         LSP:=CHARPTR;                                                              
00648700       END ELSE BEGIN                                                               
00648800         NEW(LSP,OTHERSTRUCTSIZE);                                                  
00648900         AELTYPE(LSP):=CHARPTR;                                                     
00649000         SWORDS(LSP):=LENGTH;                                                       
00649100         FORM(LSP):=ARRAYS;                                                         
00649200         PACKED(LSP):=PACKEDSTRUC;                                                  
00649300         BITS(LSP):=CHARBITSIZE;                                                    
00649400         ELSPERWORD(LSP):=CHARSPERWORD;                                             
00649500         % FOR COMPATIBILITY AND CONSISTENCY A STRING IS A                          
00649600         % PACKED ARRAY[1..N] OF CHAR, SO PUT BOUNDS IN                             
00649700         NEW(LSP1,SUBRANGESTRUCTSIZE);                                              
00649800         FORM(LSP1):=SUBRANGE;                                                      
00649900         RANGETYPE(LSP1):=INTPTR;                                                   
00650000         SMIN(LSP1):=1;                                                             
00650100         SWORDS(LSP1):=INTSIZE;                                                     
00650200         SMAX(LSP1):=LENGTH;                                                        
00650300         INXTYPE(LSP):=LSP1;                                                        
00650400       END;                                                                         
00650500       FVALUE:=VAL;                                                                 
00650600       INSYMBOL;                                                                    
00650700     END ELSE BEGIN                                                                 
00650800       SIGN:=NONE;                                                                  
00650900       IF (SYMBOL=ADDOP) AND INTEST(OP,PLUSMINUSSET) THEN BEGIN                     
00651000         SIGN:=(IF (OP=PLUS) THEN POS ELSE NEG);                                    
00651100         INSYMBOL;                                                                  
00651200       END;                                                                         
00651300       IF (SYMBOL = IDENT) THEN BEGIN                                               
00651400         SEARCHID(KONSTSET,LIP);                                                    
00651500         LSP:=IDTYPE(LIP);                                                          
00651600         FVALUE:=VALUES(LIP);                                                       
00651700         IF (SIGN NEQ NONE) THEN BEGIN                                              
00651800           IF (LSP = NIL) THEN BEGIN                                                
00651900             ERROR(2344);                                                           
00652000           END ELSE BEGIN                                                           
00652100             IF (LSP=INTPTR) OR (LSP=REALPTR) THEN BEGIN                            
00652200               IF (SIGN=NEG) THEN FVALUE:=-FVALUE;                                  
00652300             END ELSE BEGIN                                                         
00652400               ERROR(2341);                                                         
00652500             END;                                                                   
00652600           END;                                                                     
00652700         END;                                                                       
00652800         INSYMBOL;                                                                  
00652900       END ELSE IF (SYMBOL=INTCONST) THEN BEGIN                                     
00653000         IF (SIGN=NEG) THEN VAL:=-VAL;                                              
00653100         LSP:=INTPTR;                                                               
00653200         FVALUE:=VAL;                                                               
00653300         INSYMBOL;                                                                  
00653400       END ELSE IF (SYMBOL=REALCONST) THEN BEGIN                                    
00653500         IF (SIGN=NEG) THEN VAL:=-VAL;                                              
00653600         LSP:=REALPTR;                                                              
00653700         FVALUE:=VAL;                                                               
00653800         INSYMBOL;                                                                  
00653900       END ELSE BEGIN                                                               
00654000         ERROR(2342);                                                               
00654100         SKIP(FSYMBOLSET);                                                          
00654200       END;                                                                         
00654300       IF NOT SYMBOLIN(FSYMBOLSET) THEN BEGIN                                       
00654400         ERROR(2343);                                                               
00654500         SKIP(FSYMBOLSET);                                                          
00654600       END;                                                                         
00654700     END; % OF IF SYMBOLIN                                                          
00654800   END;                                                                             
00654900   FSP:=LSP;                                                                        
00655000 END; % OF CONSTANT                                                                 
00655100                                                                                    
00655200                                                                                    
00655300  $SET OMIT = NAMECOMP                                                              
00655400 BOOLEAN PROCEDURE COMPTYPES(FSP1,FSP2);                                            
00655500 %                 *********                                                        
00655600 VALUE FSP1,FSP2;                                                                   
00655700 TYPESTRUCTPTR FSP1,FSP2;                                                           
00655800 BEGIN                                                                              
00655900   TYPEIDENTPTR NXT1,NXT2;                                                          
00656000   BOOLEAN COMP;                                                                    
00656100   TYPETESTP LTESTP1,LTESTP2;                                                       
00656200   %                                                                                
00656300   IF (FSP1 = FSP2) THEN BEGIN                                                      
00656400     COMPTYPES:=TRUE;                                                               
00656500   END ELSE BEGIN                                                                   
00656600     IF (FSP1 NEQ NIL) AND (FSP2 NEQ NIL) THEN BEGIN                                
00656700       IF (FORM(FSP1) = FORM(FSP2)) THEN BEGIN                                      
00656800         CASE FORM(FSP1) OF BEGIN                                                   
00656900         SCALAR:                                                                    
00657000           COMPTYPES:=FALSE;                                                        
00657100         SUBRANGE:                                                                  
00657200           COMPTYPES:=COMPTYPES(RANGETYPE(FSP1),RANGETYPE(FSP2));                   
00657300         POINTERS:                                                                  
00657400           COMP:=FALSE;                                                             
00657500           LTESTP1:=LTESTP2:=GLOBTESTP;                                             
00657600           WHILE (LTESTP1 NEQ NIL) DO BEGIN                                         
00657700             IF (ELT1(LTESTP1) = ELTYPE(FSP1)) AND                                  
00657800               (ELT2(LTESTP1) = ELTYPE(FSP2)) THEN COMP:=TRUE;                      
00657900             LTESTP1:=LASTTESTP(LTESTP1);                                           
00658000           END; % OF WHILE                                                          
00658100           IF NOT COMP THEN BEGIN                                                   
00658200             NEW(LTESTP1,TESTPSIZE);                                                
00658300             ELT1(LTESTP1):=ELTYPE(FSP1); ELT2(LTESTP1):=ELTYPE(FSP2);              
00658400             LASTTESTP(LTESTP1):=GLOBTESTP;                                         
00658500             GLOBTESTP:=LTESTP1;                                                    
00658600             COMP:=COMPTYPES(ELTYPE(FSP1),ELTYPE(FSP2));                            
00658700           END; % OF IF                                                             
00658800           COMPTYPES:=COMP;                                                         
00658900           GLOBTESTP:=LTESTP2;                                                      
00659000         POWER:                                                                     
00659100           COMPTYPES:=COMPTYPES(ELSET(FSP1),ELSET(FSP2));                           
00659200         ARRAYS:                                                                    
00659300           COMPTYPES:=COMPTYPES(AELTYPE(FSP1),AELTYPE(FSP2))                        
00659400             AND (PACKED(FSP1) = PACKED(FSP2))                                      
00659500             AND (SWORDS(FSP1) = SWORDS(FSP2));                                     
00659600         RECORDS:                                                                   
00659700           NXT1:=FSTFLD(FSP1);                                                      
00659800           NXT2:=FSTFLD(FSP2);                                                      
00659900           COMP:=PACKED(FSP1)=PACKED(FSP2);                                         
00660000           WHILE (NXT1 NEQ NIL) AND (NXT2 NEQ NIL) DO BEGIN                         
00660100             COMP:=COMP AND                                                         
00660200               COMPTYPES(IDTYPE(NXT1),IDTYPE(NXT2));                                
00660300             NXT1:=NEXT(NXT1);                                                      
00660400             NXT2:=NEXT(NXT2);                                                      
00660500           END;                                                                     
00660600           COMPTYPES:=COMP AND                                                      
00660700             (NXT1 = NIL) AND (NXT2 = NIL) AND                                      
00660800             (RECVAR(FSP1) = NIL) AND (RECVAR(FSP2) = NIL);                         
00660900         FILES:                                                                     
00661000           COMPTYPES:=COMPTYPES(FILTYPE(FSP1),FILTYPE(FSP2));                       
00661100         END; % OF CASE                                                             
00661200       END ELSE BEGIN                                                               
00661300         % NOT EQUAL FORMS                                                          
00661400         IF (FORM(FSP1) = SUBRANGE) THEN BEGIN                                      
00661500           COMPTYPES:=COMPTYPES(RANGETYPE(FSP1),FSP2);                              
00661600         END ELSE IF (FORM(FSP2) = SUBRANGE) THEN BEGIN                             
00661700           COMPTYPES:=COMPTYPES(FSP1,RANGETYPE(FSP2));                              
00661800         END ELSE BEGIN                                                             
00661900           COMPTYPES:=FALSE;                                                        
00662000         END;                                                                       
00662100       END;                                                                         
00662200     END ELSE BEGIN                                                                 
00662300       % SOMETHING WAS NIL                                                          
00662400       COMPTYPES:=TRUE;                                                             
00662500     END;                                                                           
00662600   END;                                                                             
00662700 END; % OF COMPATIBILITY OF TYPE TESTS                                              
00662800                                                                                    
00662900  $POP OMIT                                                                         
00663000                                                                                    
00663100                                                                                    
00663200 BOOLEAN PROCEDURE STRING(FSP);                                                     
00663300 %                 ******                                                           
00663400 VALUE FSP;                                                                         
00663500 TYPESTRUCTPTR FSP;                                                                 
00663600 BEGIN                                                                              
00663700   STRING:=FALSE;                                                                   
00663800   IF (FSP NEQ NIL) THEN BEGIN                                                      
00663900     IF (FORM(FSP) = ARRAYS) THEN BEGIN                                             
00664000       IF(PACKED(FSP)=PACKEDSTRUC) THEN BEGIN                                       
00664100         IF (AELTYPE(FSP)=CHARPTR) THEN BEGIN                                       
00664200           IF (INXTYPE(FSP) NEQ NIL) THEN BEGIN                                     
00664300             IF (FORM(INXTYPE(FSP))=SUBRANGE) THEN BEGIN                            
00664400               IF (RANGETYPE(INXTYPE(FSP))=INTPTR) THEN BEGIN                       
00664500                 IF (SMIN(INXTYPE(FSP))=1) THEN BEGIN                               
00664600                   STRING:=TRUE;                                                    
00664700                 END;                                                               
00664800               END;                                                                 
00664900             END;                                                                   
00665000           END;                                                                     
00665100         END;                                                                       
00665200       END;                                                                         
00665300     END;                                                                           
00665400   END;                                                                             
00665500 END; % OF STRING                                                                   
00665600                                                                                    
00665700  $SET OMIT = NOT NAMECOMP                                                          
00665800                                                                                    
00665900 BOOLEAN PROCEDURE IDENTCOMPTYPES(FSP1,FSP2);                                       
00666000 %                 **************                                                   
00666100 VALUE FSP1,FSP2;                                                                   
00666200 TYPESTRUCTPTR FSP1,FSP2;                                                           
00666300 BEGIN                                                                              
00666400                                                                                    
00666500 IF (FSP1 = FSP2) THEN BEGIN                                                        
00666600   IDENTCOMPTYPES := TRUE;                                                          
00666700 END ELSE BEGIN                                                                     
00666800   IF ((FSP1=NIL) OR (FSP2=NIL)) THEN BEGIN                                         
00666900     IDENTCOMPTYPES := TRUE;                                                        
00667000   END ELSE BEGIN                                                                   
00667100     IDENTCOMPTYPES := FALSE;                                                       
00667200   END;                                                                             
00667300 END;                                                                               
00667400 END;   %OF IDENTCOMPTYPES                                                          
00667500                                                                                    
00667600 BOOLEAN PROCEDURE COMPTYPES(FSP1,FSP2);                                            
00667700 %                 *********                                                        
00667800 VALUE FSP1,FSP2;                                                                   
00667900 TYPESTRUCTPTR FSP1,FSP2;                                                           
00668000 BEGIN                                                                              
00668100 BOOLEAN ACOMPTYPES;                                                                
00668200                                                                                    
00668300 ACOMPTYPES := IDENTCOMPTYPES(FSP1,FSP2);                                           
00668400 IF NOT ACOMPTYPES THEN BEGIN                                                       
00668500   IF (FORM(FSP1) = SUBRANGE) THEN BEGIN                                            
00668600     IF (FORM(FSP2) = SUBRANGE) THEN BEGIN                                          
00668700       ACOMPTYPES := COMPTYPES(RANGETYPE(FSP1),RANGETYPE(FSP2));                    
00668800     END ELSE BEGIN                                                                 
00668900       ACOMPTYPES := COMPTYPES(RANGETYPE(FSP1),FSP2);                               
00669000     END;                                                                           
00669100   END ELSE BEGIN                                                                   
00669200     IF (FORM(FSP2) = SUBRANGE) THEN BEGIN                                          
00669300       ACOMPTYPES := COMPTYPES(FSP1,RANGETYPE(FSP2));                               
00669400     END ELSE BEGIN                                                                 
00669500       IF STRING(FSP1) THEN BEGIN                                                   
00669600         IF STRING(FSP2) THEN BEGIN                                                 
00669700           IF (SWORDS(FSP1) = SWORDS(FSP2)) THEN BEGIN                              
00669800             ACOMPTYPES := TRUE;                                                    
00669900           END;                                                                     
00670000         END;                                                                       
00670100       END ELSE BEGIN                                                               
00670200         IF (FORM(FSP1) = POWER) THEN BEGIN                                         
00670300           IF (FORM(FSP2)=POWER) THEN BEGIN                                         
00670400             ACOMPTYPES := COMPTYPES(ELSET(FSP1),ELSET(FSP2));                      
00670500           END;                                                                     
00670600         END ELSE BEGIN                                                             
00670700           IF (FORM(FSP1)=POINTERS) THEN BEGIN                                      
00670800             IF (FORM(FSP2)=POINTERS) THEN BEGIN                                    
00670900               IF (FSP1=NILPTR) OR (FSP2=NILPTR) THEN BEGIN                         
00671000                 ACOMPTYPES := TRUE;                                                
00671100               END;                                                                 
00671200             END;                                                                   
00671300           END;                                                                     
00671400         END;                                                                       
00671500       END;                                                                         
00671600     END;                                                                           
00671700   END;                                                                             
00671800 END;                                                                               
00671900 COMPTYPES := ACOMPTYPES;                                                           
00672000 END;   % OF COMPTYPES                                                              
00672100 BOOLEAN PROCEDURE ASSCOMPTYPES(FSP1,FSP2);                                         
00672200 %                 ************                                                     
00672300 VALUE FSP1,FSP2;                                                                   
00672400 TYPESTRUCTPTR FSP1,FSP2;                                                           
00672500 BEGIN                                                                              
00672600 BOOLEAN ACOMPTYPES;                                                                
00672700 INTEGER LB1,LB2,UB1,UB2;                                                           
00672800                                                                                    
00672900 ACOMPTYPES := IDENTCOMPTYPES(FSP1,FSP2);                                           
00673000 IF ACOMPTYPES THEN BEGIN                                                           
00673100   IF (FORM(FSP1) = FILES) OR (FORM(FSP2) = FILES) THEN BEGIN                       
00673200     ACOMPTYPES := FALSE;                                                           
00673300   END;                                                                             
00673400 END ELSE BEGIN                                                                     
00673500   ACOMPTYPES := COMPTYPES(FSP1,FSP2);                                              
00673600   IF ACOMPTYPES THEN BEGIN                                                         
00673700     IF (FORM(FSP1)=POWER) THEN BEGIN                                               
00673800       ACOMPTYPES := (LONGSET(FSP1) AND LONGSET(FSP2)) OR                           
00673900                     (SHORTSET(FSP1) AND SHORTSET(FSP2));                           
00674000     END;                                                                           
00674100   END;                                                                             
00674200   IF ACOMPTYPES THEN BEGIN                                                         
00674300     IF LONGSET(FSP1) THEN BEGIN                                                    
00674400       GETBOUNDS(ELSET(FSP1),LB1,UB1);                                              
00674500       GETBOUNDS(ELSET(FSP2),LB2,UB2);                                              
00674600       ACOMPTYPES:=LB1=LB2;                                                         
00674700     END;                                                                           
00674800   END ELSE BEGIN                                                                   
00674900     IF (FSP1 = REALPTR) THEN BEGIN                                                 
00675000       IF COMPTYPES(FSP2,INTPTR) THEN BEGIN                                         
00675100         ACOMPTYPES := TRUE;                                                        
00675200       END;                                                                         
00675300     END;                                                                           
00675400   END;                                                                             
00675500 END;                                                                               
00675600 ASSCOMPTYPES := ACOMPTYPES;                                                        
00675700 END;   %OF ASSCOMPTYPES                                                            
00675800                                                                                    
00675900  $POP OMIT                                                                         
00676000                                                                                    
00676100 PROCEDURE TYP(FSYS,FSP,FSIZE,FBITS);                                               
00676200 %         ***                                                                      
00676300 VALUE FSYS;                                                                        
00676400 TYPESETOFSYS FSYS;                                                                 
00676500 TYPESTRUCTPTR FSP;                                                                 
00676600 INTEGER FSIZE,FBITS;                                                               
00676700 BEGIN                                                                              
00676800   TYPESTRUCTPTR LSP,LSP1,LSP2;                                                     
00676900   TYPEIDENTPTR LCP;                                                                
00677000   INTEGER OLDTOP,LSIZE,DISPL,MAXREC,ATTSIZE,LBITS,NEXTBIT;                         
00677100   INTEGER LMIN,LMAX;                                                               
00677200   REAL ARRAY FILEATTS[0:4*CHUNK-1];                                                
00677300   BOOLEAN PACKEDSPEC;                                                              
00677400                                                                                    
00677500 PROCEDURE FILEATTRIBUTES;                                                          
00677600 %         **************                                                           
00677700 BEGIN                                                                              
00677800   INTEGER                                                                          
00677900     I,J,K,                                                                         
00678000     ATTRIBUTENO,                                                                   
00678100     NOCHARS,                                                                       
00678200     ATTRIBUTEPARAMTYPE,                                                            
00678300     SIZEFPB,                                                                       
00678400     ATTOPTIONNO;                                                                   
00678500   BOOLEAN                                                                          
00678600     KINDSPECIFIED,                                                                 
00678700     MAXRECSPECIFIED,                                                               
00678800     CHARUNITS,                                                                     
00678900     ATTRIBUTEFOUND,                                                                
00679000     FOUND;                                                                         
00679100   EBCDIC ARRAY                                                                     
00679200     ATTBUFF[0:72];                                                                 
00679300                                                                                    
00679400   VALUE ARRAY FILEATTRIBUTESTABLE (    %STRUCTURE                                  
00679500                              %[47:8] - NO CHARS IN ATT. NAME                       
00679600                              %[39:8] - TYPE OF PARAMETER EXPECTED                  
00679700                                 %1 - INTEGER                                       
00679800                                 %2 - FILENAME                                      
00679900                                 %3 - INTEGER OR STRING                             
00680000                                 %4 - BOOLEAN                                       
00680100                              %[31:8] - ATTRIBUTE NUMBER                            
00680200                              %THEN ATTRIBUTE                                       
00680300     40"050112"8"AREAS",                                                            
00680400     40"080111"8"AREASIZE",                                                         
00680500     40"09010E"8"BLOCKSIZE",                                                        
00680600     40"07011A"8"BUFFERS",                                                          
00680700     40"070306"8"DENSITY",                                                          
00680800     40"09045A"8"EXCLUSIVE",                                                        
00680900     40"07030A"8"EXTMODE",                                                          
00681000     40"0A0227"8"FAMILYNAME",                                                       
00681100     40"08013A"8"FILEKIND",                                                         
00681200     40"08010D"8"FILETYPE",                                                         
00681300     40"080416"8"FLEXIBLE",                                                         
00681400     40"07031D"8"INTMODE",                                                          
00681500     40"040308"8"KIND",                                                             
00681600     40"0A010F"8"MAXRECSIZE",                                                       
00681700     40"0A0110"8"MINRECSIZE",                                                       
00681800     40"050314"8"MYUSE",                                                            
00681900     40"080227"8"PACKNAME",                                                         
00682000     40"0A030C"8"PROTECTION",                                                       
00682100     40"0A0105"8"SAVEFACTOR",                                                       
00682200     40"0D0249"8"SECURITYGUARD",                                                    
00682300     40"0C0350"8"SECURITYTYPE",                                                     
00682400     40"0B0351"8"SECURITYUSE",                                                      
00682500     40"050200"8"TITLE",                                                            
00682600     40"050349"8"UNITS"                                                             
00682700     );                                                                             
00682800                                                                                    
00682900   DEFINE NOFILEATTRIBUTES = 24#,                                                   
00683000          SIZEATTRIBUTEBITS = [47:8]#,                                              
00683100          PARAMTYPEBITS = [39:8]#,                                                  
00683200          ATTRIBNOBITS = [31:8]#;                                                   
00683300                                                                                    
00683400   VALUE ARRAY STRINGORINTEGEROPTIONS (                                             
00683500                              %STRUCTURE -                                          
00683600                              %[47:8] - ATTRIBUTE NUMBER                            
00683700                              %[39:8] - SIZE MNEUMONIC NAME                         
00683800                              %[31:8] VALUE OF MNEUMONIC                            
00683900                              %THEN MNEUMONIC                                       
00684000                              %IF KIND MNEUMONIC THEN NEXT CHAR = DEFAULT           
00684100                              %MAXRECSIZE                                           
00684200     40"060400"8"HIGH",                                                             
00684300     40"060601"8"MEDIUM",                                                           
00684400     40"060302"8"LOW",                                                              
00684500     40"060503"8"SUPER",                                                            
00684600     40"0A0600"8"SINGLE",                                                           
00684700     40"0A0302"8"HEX",                                                              
00684800     40"0A0303"8"BCL",                                                              
00684900     40"0A0604"8"EBCDIC",                                                           
00685000     40"0A0505"8"ASCII",                                                            
00685100     40"0A0606"8"BINARY",                                                           
00685200     40"1D0600"8"SINGLE",                                                           
00685300     40"1D0302"8"HEX",                                                              
00685400     40"1D0303"8"BCL",                                                              
00685500     40"1D0604"8"EBCDIC",                                                           
00685600     40"1D0505"8"ASCII",                                                            
00685700     40"080401"8"DISK"4"1E",                                                        
00685800     40"080603"8"REMOTE"4"0C",                                                      
00685900     40"080707"8"PRINTER"4"16",                                                     
00686000     40"080609"8"READER"4"0E",                                                      
00686100     40"08050D"8"TAPE7"4"0A",                                                       
00686200     40"08050E"8"TAPE9"4"0A",                                                       
00686300     40"08060F"8"PETAPE"4"0A",                                                      
00686400     40"08042D"8"TAPE"4"0A",                                                        
00686500     40"080411"8"PACK"4"1E",                                                        
00686600     40"140600"8"CLOSED",                                                           
00686700     40"140201"8"IN",                                                               
00686800     40"140302"8"OUT",                                                              
00686900     40"140203"8"IO",                                                               
00687000     40"0C0900"8"TEMPORARY",                                                        
00687100     40"0C0401"8"SAVE",                                                             
00687200     40"0C0902"8"PROTECTED",                                                        
00687300     40"500700"8"PRIVATE",                                                          
00687400     40"500601"8"CLASSA",                                                           
00687500     40"500601"8"PUBLIC",                                                           
00687600     40"500702"8"GUARDED",                                                          
00687700     40"500602"8"CLASSB",                                                           
00687800     40"510700"8"SECURED",                                                          
00687900     40"510201"8"IN",                                                               
00688000     40"510302"8"OUT",                                                              
00688100     40"510203"8"IO",                                                               
00688200     40"490500"8"WORDS",                                                            
00688300     40"490A01"8"CHARACTERS"                                                        
00688400     );                                                                             
00688500                                                                                    
00688600   DEFINE NOSTRINGORINTEGEROPTIONS = 42#,                                           
00688700        SATTNOBITS = [47:8]#,                                                       
00688800        SIZEMNEUMONICBITS = [39:8]#,                                                
00688900        VALUEMNEUMONICBITS = [31:8]#;                                               
00689000                                                                                    
00689100   DEFINE                                                                           
00689200     GENATTSYL(I) =                                                                 
00689300     BEGIN                                                                          
00689400       REPLACE POINTER(FILEATTS)+SIZEFPB BY (I).[7:48] FOR 1;                       
00689500       SIZEFPB := * + 1;                                                            
00689600     END#,                                                                          
00689700                                                                                    
00689800     SEARCHATTRIBUTESTABLE =                                                        
00689900     BEGIN                                                                          
00690000       I := J := 0;                                                                 
00690100       ATTRIBUTEFOUND := FALSE;                                                     
00690200       WHILE((NOT ATTRIBUTEFOUND) AND (J <NOFILEATTRIBUTES)) DO                     
00690300       BEGIN                                                                        
00690400         NOCHARS := FILEATTRIBUTESTABLE[I].SIZEATTRIBUTEBITS;                       
00690500         IF((LENGTH-1) = NOCHARS) THEN                                              
00690600         BEGIN                                                                      
00690700           IF (NAMEBUF1 = POINTER(FILEATTRIBUTESTABLE[I]) +3 FOR                    
00690800             (LENGTH-1)) THEN                                                       
00690900           BEGIN                                                                    
00691000             ATTRIBUTEFOUND := TRUE;                                                
00691100             ATTRIBUTENO := FILEATTRIBUTESTABLE[I].ATTRIBNOBITS;                    
00691200             ATTRIBUTEPARAMTYPE := FILEATTRIBUTESTABLE[I].PARAMTYPEBITS;            
00691300           END;                                                                     
00691400         END;                                                                       
00691500         I := I + (NOCHARS + 2)DIV 6 + 1;                                           
00691600         J := J + 1;                                                                
00691700       END;                                                                         
00691800     END#,                                                                          
00691900                                                                                    
00692000     GETEQUALS =                                                                    
00692100     BEGIN                                                                          
00692200       INSYMBOL;                                                                    
00692300       IF NOT (SYMBOL = RELOP AND OP = EQOP) THEN ERROR(2142);                      
00692400     END#,                                                                          
00692500                                                                                    
00692600     CHECKSTRINGOPTION =                                                            
00692700     BEGIN                                                                          
00692800       I := J := 0;                                                                 
00692900       FOUND := FALSE;                                                              
00693000       WHILE ((NOT FOUND) AND (J < NOSTRINGORINTEGEROPTIONS)) DO                    
00693100       BEGIN                                                                        
00693200         IF(STRINGORINTEGEROPTIONS[I].SATTNOBITS = ATTRIBUTENO) THEN                
00693300         BEGIN                                                                      
00693400           IF((LENGTH-1) = STRINGORINTEGEROPTIONS[I].SIZEMNEUMONICBITS)             
00693500             THEN                                                                   
00693600           BEGIN                                                                    
00693700             IF(NAMEBUF1 = POINTER(STRINGORINTEGEROPTIONS[I])+3  FOR                
00693800               (LENGTH-1)) THEN                                                     
00693900             BEGIN                                                                  
00694000               FOUND := TRUE;                                                       
00694100               ATTOPTIONNO:=STRINGORINTEGEROPTIONS[I].VALUEMNEUMONICBITS;           
00694200               K := I;                                                              
00694300             END;                                                                   
00694400           END;                                                                     
00694500         END;                                                                       
00694600         I := I+((STRINGORINTEGEROPTIONS[I].SIZEMNEUMONICBITS + 2)DIV 6)            
00694700          + 1;                                                                      
00694800         J := J + 1;                                                                
00694900       END;                                                                         
00695000       IF (NOT FOUND) THEN                                                          
00695100       BEGIN                                                                        
00695200         ERROR(2143);                                                               
00695300         ATTOPTIONNO := 0;                                                          
00695400       END;                                                                         
00695500       IF (ATTRIBUTENO=73 AND ATTOPTIONNO=1) THEN CHARUNITS := TRUE;                
00695600     END#,                                                                          
00695700                                                                                    
00695800     CHECKINTEGEROPTION =                                                           
00695900     BEGIN                                                                          
00696000       I := J := 0;                                                                 
00696100       FOUND := FALSE;                                                              
00696200       WHILE ((NOT FOUND) AND (J < NOSTRINGORINTEGEROPTIONS)) DO                    
00696300       BEGIN                                                                        
00696400         IF(ATTRIBUTENO = STRINGORINTEGEROPTIONS[I].SATTNOBITS) THEN                
00696500         BEGIN                                                                      
00696600           IF(VAL = STRINGORINTEGEROPTIONS[I].VALUEMNEUMONICBITS)                   
00696700              THEN                                                                  
00696800           BEGIN                                                                    
00696900             FOUND := TRUE;                                                         
00697000           K := I;                                                                  
00697100           END;                                                                     
00697200         END;                                                                       
00697300         I := I + ((STRINGORINTEGEROPTIONS[I].SIZEMNEUMONICBITS + 2) DIV            
00697400           6) + 1;                                                                  
00697500         J := J + 1;                                                                
00697600       END;                                                                         
00697700       IF (ATTRIBUTENO=73 AND VAL=1) THEN CHARUNITS := TRUE;                        
00697800       IF (NOT FOUND) THEN                                                          
00697900       BEGIN                                                                        
00698000         ERROR(2144);                                                               
00698100         VAL := 0;            %DEFAULT VALUE                                        
00698200       END;                                                                         
00698300     END#;                                                                          
00698400                                                                                    
00698500     DEFINE                                                                         
00698600       INTEGERATTRIBUTE = 1#,                                                       
00698700       STRINGATTRIBUTE = 2#,                                                        
00698800       STRINGORINTEGERATTRIBUTE = 3#,                                               
00698900       BOOLEANATTRIBUTE = 4#;                                                       
00699000                                                                                    
00699100                                                                                    
00699200 %--------MAIN SECTION OF FILE ATTRIBUTES--------------------------------           
00699300 KINDSPECIFIED:=FALSE;                                                              
00699400 MAXRECSPECIFIED:=FALSE;                                                            
00699500 IF(SYMBOL=LPARENT) THEN BEGIN                                                      
00699600   INSYMBOL;                                                                        
00699700   MAXREC :=0;                                                                      
00699800   GENATTSYL(3); GENATTSYL(4"1D"); GENATTSYL(4);  %INTMODE=EBCDIC                   
00699900   WHILE (SYMBOL = IDENT) DO                                                        
00700000   BEGIN                                                                            
00700100     SEARCHATTRIBUTESTABLE;                                                         
00700200     IF ATTRIBUTEFOUND THEN                                                         
00700300     BEGIN                                                                          
00700400       CASE ATTRIBUTEPARAMTYPE OF                                                   
00700500       BEGIN                                                                        
00700600       INTEGERATTRIBUTE:                                                            
00700700       BEGIN                                                                        
00700800         GETEQUALS;                                                                 
00700900         INSYMBOL;                                                                  
00701000         IF(SYMBOL NEQ INTCONST) THEN ERROR(2145);                                  
00701100         GENATTSYL(IF(VAL<256) THEN 3                                               
00701200                   ELSE IF(VAL <65536) THEN 4                                       
00701300                        ELSE 5);                                                    
00701400         GENATTSYL(ATTRIBUTENO);                                                    
00701500         IF(VAL > 65535) THEN GENATTSYL(VAL DIV 65536);                             
00701600         IF(VAL > 255) THEN GENATTSYL(VAL DIV 256);                                 
00701700         GENATTSYL(VAL MOD 256);                                                    
00701800         IF(ATTRIBUTENO = 15) THEN BEGIN                                            
00701900           MAXREC := VAL;                                                           
00702000           MAXRECSPECIFIED := TRUE;                                                 
00702100         END;                                                                       
00702200       END;                                                                         
00702300       STRINGATTRIBUTE:                                                             
00702400       BEGIN                                                                        
00702500         GETEQUALS;                                                                 
00702600         INSYMBOL;                                                                  
00702700         IF(SYMBOL = STRINGCONST) THEN                                              
00702800         BEGIN                                                                      
00702900           IF(NAMEBUF0+(LENGTH) NEQ "." FOR 1) THEN                                 
00703000           BEGIN                                                                    
00703100             REPLACE NAMEBUF0+(LENGTH+1) BY "." FOR 1;                              
00703200             NAMEBUF[0].[47:8] := LENGTH := * + 1;                                  
00703300           END;                                                                     
00703400           GENATTSYL(2);                                                            
00703500           GENATTSYL(ATTRIBUTENO);                                                  
00703600           GENATTSYL((LENGTH));                                                     
00703700           FOR I := 1 STEP 1 UNTIL (LENGTH) DO                                      
00703800             GENATTSYL(REAL(NAMEBUF0+I,1));                                         
00703900         END                                                                        
00704000         ELSE IF (SYMBOLIN(IDENTLPARENTSET)) THEN                                   
00704100         BEGIN                                                                      
00704200           I := 0;                                                                  
00704300           IF (SYMBOL=LPARENT) THEN BEGIN                                           
00704400             INSYMBOL;                                                              
00704500             IF (SYMBOL=IDENT) THEN BEGIN                                           
00704600               REPLACE ATTBUFF[I] BY "(" FOR 1,                                     
00704700                 NAMEBUF1 FOR (NAMEBUF[0].[47:8]-1),                                
00704800                 ")" FOR 1;                                                         
00704900               I:=I+NAMEBUF[0].[47:8]+1;                                            
00705000             END ELSE BEGIN                                                         
00705100               ERROR(2146);                                                         
00705200             END;                                                                   
00705300             INSYMBOL;                                                              
00705400             IF(SYMBOL=RPARENT) THEN INSYMBOL;                                      
00705500           END;                                                                     
00705600           DO                                                                       
00705700           BEGIN                                                                    
00705800             IF (SYMBOL=IDENT) THEN BEGIN                                           
00705900               REPLACE ATTBUFF[I] BY NAMEBUF1 FOR (NAMEBUF[0].[47:8]-1);            
00706000               I := I + NAMEBUF[0].[47:8]-1;                                        
00706100             END ELSE BEGIN                                                         
00706200               IF (SYMBOL=INTCONST) THEN BEGIN                                      
00706300                 REPLACE ATTBUFF[I] BY VAL FOR LENGTH DIGITS;   %INTEGER            
00706400                 I := I + LENGTH;                                                   
00706500               END ELSE BEGIN                                                       
00706600                 ERROR(2151);                                                       
00706700               END;                                                                 
00706800             END;                                                                   
00706900             INSYMBOL;                                                              
00707000             IF (SYMBOL = MULOP AND OP = REALDIV) THEN                              
00707100             BEGIN                                                                  
00707200               REPLACE ATTBUFF[I] BY "/" FOR 1;                                     
00707300               I := I + 1;                                                          
00707400               INSYMBOL;                                                            
00707500             END;                                                                   
00707600           END UNTIL (SYMBOL NEQ IDENT) AND (SYMBOL NEQ INTCONST);                  
00707700           REPLACE ATTBUFF[I] BY "." FOR 1;                                         
00707800           I := I + 1;                                                              
00707900           IF (SYMBOL = PERIOD) THEN INSYMBOL;                                      
00708000           GENATTSYL(2);                                                            
00708100           GENATTSYL(ATTRIBUTENO);                                                  
00708200           GENATTSYL(I);                                                            
00708300           I :=0;                                                                   
00708400           DO                                                                       
00708500           BEGIN                                                                    
00708600             GENATTSYL(REAL(ATTBUFF[I],1));                                         
00708700             I := I + 1;                                                            
00708800           END UNTIL (ATTBUFF[I-1] EQL "." FOR 1);                                  
00708900         END                                                                        
00709000         ELSE                                                                       
00709100           ERROR(2146);                                                             
00709200       END;                                                                         
00709300       STRINGORINTEGERATTRIBUTE:                                                    
00709400       BEGIN                                                                        
00709500         GETEQUALS;                                                                 
00709600         INSYMBOL;                                                                  
00709700         CASE SYMBOL OF                                                             
00709800         BEGIN                                                                      
00709900         RELOP:                                                                     
00710000         BEGIN                                                                      
00710100           LENGTH:=*+1;                                                             
00710200           CHECKSTRINGOPTION;                                                       
00710300           GENATTSYL(3);                                                            
00710400           GENATTSYL(ATTRIBUTENO);                                                  
00710500           GENATTSYL(ATTOPTIONNO);                                                  
00710600         END;                                                                       
00710700         IDENT:                                                                     
00710800         BEGIN                                                                      
00710900           CHECKSTRINGOPTION;                                                       
00711000           GENATTSYL(3);                                                            
00711100           GENATTSYL(ATTRIBUTENO);                                                  
00711200           GENATTSYL(ATTOPTIONNO);                                                  
00711300         END;                                                                       
00711400         INTCONST:                                                                  
00711500         BEGIN                                                                      
00711600           CHECKINTEGEROPTION;                                                      
00711700           GENATTSYL(3);                                                            
00711800           GENATTSYL(ATTRIBUTENO);                                                  
00711900           GENATTSYL(VAL);                                                          
00712000         END;                                                                       
00712100         ELSE:                                                                      
00712200           ERROR(2147);                                                             
00712300         END;                                                                       
00712400         IF (ATTRIBUTENO = 8)  THEN BEGIN                                           
00712500           IF (MAXREC=0) THEN BEGIN                                                 
00712600             MAXREC := REAL(POINTER(STRINGORINTEGEROPTIONS[K]) +                    
00712700                      (STRINGORINTEGEROPTIONS[K].SIZEMNEUMONICBITS+3),1);           
00712800           END;                                                                     
00712900         END;                                                                       
00713000       END;                                                                         
00713100       BOOLEANATTRIBUTE:                                                            
00713200       BEGIN                                                                        
00713300         INSYMBOL;                                                                  
00713400         IF(SYMBOL = RELOP AND OP = EQOP) THEN                                      
00713500         BEGIN                                                                      
00713600           INSYMBOL;                                                                
00713700           IF (SYMBOL = IDENT) THEN                                                 
00713800           BEGIN                                                                    
00713900             IF (NAMEBUF1 = "TRUE" FOR 4) THEN I := 1                               
00714000             ELSE IF(NAMEBUF1 = "FALSE" FOR 5) THEN I := 0                          
00714100                  ELSE ERROR(2148);                                                 
00714200             GENATTSYL(3);                                                          
00714300             GENATTSYL(ATTRIBUTENO);                                                
00714400             GENATTSYL(I);                                                          
00714500           END                                                                      
00714600           ELSE                                                                     
00714700             ERROR(2149);                                                           
00714800         END                                                                        
00714900         ELSE                                                                       
00715000         BEGIN                                                                      
00715100           GENATTSYL(3);                                                            
00715200           GENATTSYL(ATTRIBUTENO);                                                  
00715300           GENATTSYL(1);                                                            
00715400         END;                                                                       
00715500       END;                                                                         
00715600       END;                                                                         
00715700     END                                                                            
00715800     ELSE                                                                           
00715900       ERROR(2141);         %NOT VALID ATTRIBUTE                                    
00716000     IF((SYMBOL NEQ RPARENT) AND (SYMBOL NEQ SEMICOLON)) THEN                       
00716100     BEGIN                                                                          
00716200       IF(SYMBOL NEQ COMMA) THEN                                                    
00716300       BEGIN                                                                        
00716400         INSYMBOL;                                                                  
00716500       END;                                                                         
00716600       IF (SYMBOL = COMMA) THEN INSYMBOL;                                           
00716700     END;                                                                           
00716800   END;    %OF WHILE                                                                
00716900   IF(SYMBOL NEQ RPARENT) THEN ERROR(2150);                                         
00717000   INSYMBOL;                                                                        
00717100 END ELSE BEGIN                                                                     
00717200   GENATTSYL(3); GENATTSYL(29); GENATTSYL(4);  %INTMODE=EBCDIC                      
00717300 END;                                                                               
00717400 GENATTSYL(0);                                                                      
00717500 WHILE (SIZEFPB MOD CHARSPERWORD NEQ 0) DO GENATTSYL(0);                            
00717600 ATTSIZE := (SIZEFPB DIV CHARSPERWORD);                                             
00717700 IF MAXRECSPECIFIED THEN BEGIN                                                      
00717800   IF CHARUNITS THEN BEGIN                                                          
00717900     MAXREC := (MAXREC+(CHARSPERWORD-1)) DIV CHARSPERWORD;                          
00718000   END;                                                                             
00718100 END ELSE BEGIN                                                                     
00718200   IF NOT KINDSPECIFIED THEN BEGIN                                                  
00718300     MAXREC:=30;     %DEFAULT FOR DISK                                              
00718400   END;                                                                             
00718500 END;                                                                               
00718600 END;   %OF FILEATTRIBUTES                                                          
00718700                                                                                    
00718800                                                                                    
00718900 PROCEDURE SEARCHFWDCHAIN(FCP);                                                     
00719000 %         **************                                                           
00719100 TYPEIDENTPTR FCP;                                                                  
00719200 BEGIN                                                                              
00719300 TYPEIDENTPTR LSP;                                                                  
00719400 INTEGER L;                                                                         
00719500 POINTER P;                                                                         
00719600 LABEL EXIT;                                                                        
00719700 IF (FWPTR = NIL) THEN BEGIN                                                        
00719800   FCP:=NIL;                                                                        
00719900 END ELSE BEGIN                                                                     
00720000   LSP:=FWPTR;                                                                      
00720100   FCP:=NIL;                                                                        
00720200   WHILE (LSP NEQ NIL) DO BEGIN                                                     
00720300     P:=POINTER(HEAP[NAME(LSP)]);                                                   
00720400     L:=REAL(P,1);                                                                  
00720500     P:=P+1;                                                                        
00720600     IF (L=LENGTH) THEN BEGIN                                                       
00720700       IF (P=NAMEBUF1 FOR L) THEN BEGIN                                             
00720800         FCP:=LSP;                                                                  
00720900         GO TO EXIT;                                                                
00721000       END;                                                                         
00721100     END;                                                                           
00721200     LSP:=NEXT(LSP);                                                                
00721300   END;   %OF WHILE                                                                 
00721400 END;   %OF IF                                                                      
00721500 EXIT:                                                                              
00721600 END;   %OF SEARCHFWDCHAIN                                                          
00721700                                                                                    
00721800 PROCEDURE SIMPLETYPE(FSYS,FSP,FSIZE,FBITS);                                        
00721900 %         **********                                                               
00722000 VALUE FSYS;                                                                        
00722100 TYPESETOFSYS FSYS;                                                                 
00722200 TYPESTRUCTPTR FSP;                                                                 
00722300 INTEGER FSIZE,FBITS;                                                               
00722400 BEGIN                                                                              
00722500   TYPESTRUCTPTR LSP,LSP1;                                                          
00722600   TYPEIDENTPTR LCP,LCP1;                                                           
00722700   INTEGER TTOP,I;                                                                  
00722800   REAL LVALU,LCNT,LCNT2;                                                           
00722900   %                                                                                
00723000   FSIZE:=1;                                                                        
00723100   FBITS:=0;                                                                        
00723200   IF NOT SYMBOLIN(SIMPTYPEBEGSYS) THEN BEGIN                                       
00723300     ERROR(2390);                                                                   
00723400     SKIP(FSYS OR SIMPTYPEBEGSYS);                                                  
00723500   END;                                                                             
00723600   IF SYMBOLIN(SIMPTYPEBEGSYS) THEN BEGIN                                           
00723700     IF (SYMBOL = LPARENT) THEN BEGIN                                               
00723800       TTOP:=TOP;                                                                   
00723900       WHILE (OCCUR(TOP) NEQ BLCK) DO TOP:=TOP-DISPLAYSIZE;                         
00724000       NEW(LSP,OTHERSTRUCTSIZE);                                                    
00724100       SWORDS(LSP):=INTSIZE;                                                        
00724200       FORM(LSP):=SCALAR;                                                           
00724300       SCALKIND(LSP):=DECLARED;                                                     
00724400       SIO(LSP):=NOD1SLOT;                                                          
00724500       LCP1:=NIL; LCNT:=0;                                                          
00724600       DO BEGIN                                                                     
00724700         INSYMBOL;                                                                  
00724800         IF (SYMBOL = IDENT) THEN BEGIN                                             
00724900           NEWIDENTRECORDWITHNAME(LCP);                                             
00725000           IDTYPE(LCP):=LSP;                                                        
00725100           NEXT(LCP):=LCP1;                                                         
00725200           VALUES(LCP):=LCNT;                                                       
00725300           KLASS(LCP):=KONST;                                                       
00725400           ENTERID(LCP);                                                            
00725500           LCNT:=LCNT+1;                                                            
00725600           LCP1:=LCP;                                                               
00725700           INSYMBOL;                                                                
00725800         END ELSE BEGIN                                                             
00725900           ERROR(2391);                                                             
00726000         END;                                                                       
00726100         IF NOT SYMBOLIN(FSYS OR COMMARPARENTSET) THEN BEGIN                        
00726200           ERROR(2392);                                                             
00726300           SKIP(FSYS OR COMMARPARENTSET);                                           
00726400         END;                                                                       
00726500       END UNTIL (SYMBOL NEQ COMMA);                                                
00726600       FCONST(LSP):=LCP1;                                                           
00726700       LCNT2:=1;                                                                    
00726800       I:=0;                                                                        
00726900       WHILE(LCNT2 < LCNT) DO BEGIN                                                 
00727000         LCNT2 := LCNT2 * 2;                                                        
00727100         I := I+1;                                                                  
00727200       END;                                                                         
00727300       BITS(LSP):=IF (I=0) THEN 1 ELSE I;                                           
00727400       FBITS := BITS(LSP);                                                          
00727500       TOP:=TTOP;                                                                   
00727600       IF (SYMBOL = RPARENT) THEN INSYMBOL ELSE ERROR(2393);                        
00727700     END ELSE BEGIN                                                                 
00727800       IF (SYMBOL = IDENT) THEN BEGIN                                               
00727900         SEARCHID(TYPESKONST,LCP);                                                  
00728000         IF (KLASS(LCP) = KONST) THEN BEGIN                                         
00728100           NEW(LSP,SUBRANGESTRUCTSIZE);                                             
00728200           RANGETYPE(LSP):=IDTYPE(LCP);                                             
00728300           FORM(LSP):=SUBRANGE;                                                     
00728400           IF STRING(RANGETYPE(LSP)) THEN BEGIN                                     
00728500             ERROR(2394);                                                           
00728600             RANGETYPE(LSP):=NIL;                                                   
00728700           END;                                                                     
00728800           SMIN(LSP):=VALUES(LCP);                                                  
00728900           SWORDS(LSP):=INTSIZE;                                                    
00729000           BITS(LSP):=INTBITSIZE;                                                   
00729100           INSYMBOL;                                                                
00729200           IF (SYMBOL = COLON)  THEN BEGIN                                          
00729300             INSYMBOL;                                                              
00729400           END ELSE BEGIN                                                           
00729500             ERROR(2395);                                                           
00729600           END;                                                                     
00729700           CONSTANT(FSYS,LSP1,LVALU);                                               
00729800           SMAX(LSP):=LVALU;                                                        
00729900           IF (RANGETYPE(LSP) NEQ LSP1) THEN ERROR(2396);                           
00730000         END ELSE BEGIN                                                             
00730100           LSP:=IDTYPE(LCP);                                                        
00730200           IF (LSP NEQ NIL) THEN BEGIN                                              
00730300             FSIZE:=SWORDS(LSP);                                                    
00730400             FBITS:=BITS(LSP);                                                      
00730500           END;                                                                     
00730600           INSYMBOL;                                                                
00730700         END;                                                                       
00730800       END ELSE BEGIN                                                               
00730900         NEW(LSP,SUBRANGESTRUCTSIZE);                                               
00731000         FORM(LSP):=SUBRANGE;                                                       
00731100         CONSTANT(FSYS OR COLONSET,LSP1,LVALU);                                     
00731200         IF STRING(LSP1) THEN BEGIN                                                 
00731300           ERROR(2394);                                                             
00731400           LSP1:=NIL;                                                               
00731500         END;                                                                       
00731600         RANGETYPE(LSP):=LSP1;                                                      
00731700         SMIN(LSP):=LVALU;                                                          
00731800         SWORDS(LSP):=INTSIZE;                                                      
00731900         IF (SYMBOL = COLON)  THEN BEGIN                                            
00732000           INSYMBOL;                                                                
00732100         END ELSE BEGIN                                                             
00732200           ERROR(2395);                                                             
00732300         END;                                                                       
00732400         CONSTANT(FSYS,LSP1,LVALU);                                                 
00732500         SMAX(LSP):=LVALU;                                                          
00732600         LCNT:=SMAX(LSP)-SMIN(LSP)+1;                                               
00732700         LCNT2:=1;                                                                  
00732800         I:=0;                                                                      
00732900         WHILE(LCNT2<LCNT) DO BEGIN                                                 
00733000           LCNT2:=LCNT2*2;                                                          
00733100           I:=I+1;                                                                  
00733200         END;                                                                       
00733300         IF (I>BITSPERWORD) THEN I:=BITSPERWORD;                                    
00733400         BITS(LSP):=IF (I=0) THEN 1 ELSE I;                                         
00733500         FBITS:=BITS(LSP);                                                          
00733600         IF (RANGETYPE(LSP) NEQ LSP1) THEN ERROR(2396);                             
00733700       END;                                                                         
00733800       IF (LSP NEQ NIL) THEN BEGIN                                                  
00733900         IF (FORM(LSP) = SUBRANGE) THEN BEGIN                                       
00734000           IF (RANGETYPE(LSP) NEQ NIL) THEN BEGIN                                   
00734100             IF (RANGETYPE(LSP) = REALPTR) THEN BEGIN                               
00734200               ERROR(2398);                                                         
00734300             END ELSE IF (SMIN(LSP) > SMAX(LSP)) THEN BEGIN                         
00734400               ERROR(2399);                                                         
00734500             END;                                                                   
00734600           END;                                                                     
00734700         END;                                                                       
00734800       END;                                                                         
00734900     END;                                                                           
00735000     FSP:=LSP;                                                                      
00735100     IF NOT SYMBOLIN(FSYS) THEN BEGIN                                               
00735200       ERROR(2397);                                                                 
00735300       SKIP(FSYS);                                                                  
00735400     END; % OF SKIP                                                                 
00735500   END ELSE BEGIN                                                                   
00735600     FSP:=NIL;                                                                      
00735700   END;                                                                             
00735800 END; % OF SIMPLE TYPE PROCESSOR                                                    
00735900                                                                                    
00736000                                                                                    
00736100 PROCEDURE FIELDLIST(FSYS,FRECVAR);                                                 
00736200 %         *********                                                                
00736300 VALUE FSYS;                                                                        
00736400 TYPESETOFSYS FSYS;                                                                 
00736500 TYPESTRUCTPTR FRECVAR;                                                             
00736600 BEGIN                                                                              
00736700   BOOLEAN COLONPRES;                                                               
00736800   LABEL SEARCH;                                                                    
00736900   TYPEIDENTPTR LIP,LIP1,NXT,NXT1;                                                  
00737000   TYPESTRUCTPTR LSP,LSP1,LSP2,LSP3,LSP4;                                           
00737100   INTEGER MINSIZE,MAXSIZE,LSIZE,LBITS,TAGBIT;                                      
00737200   REAL LVALUE;                                                                     
00737300   DEFINE NEWFIELDRECORDWITHNAME(P) =                                               
00737400     NEW(P,FIELDSIZE+(LENGTH DIV CHARSPERWORD)+1);                                  
00737500     REPLACE POINTER(HEAP[P+FIELDSIZE]) BY NAMEBUF0 FOR (LENGTH+1);                 
00737600     NAME(P):=P+FIELDSIZE;                                                          
00737700   #;                                                                               
00737800   PROCEDURE FIELDADDRESS(NXT);                                                     
00737900   %         ************                                                           
00738000   VALUE NXT;                                                                       
00738100   INTEGER NXT;                                                                     
00738200   BEGIN                                                                            
00738300   IF PACKEDSPEC THEN BEGIN                                                         
00738400     PACKEDFIELD(NXT):=PACKEDSTRUC;                                                 
00738500     IF (FORM(IDTYPE(NXT))=ARRAYS) OR (FORM(IDTYPE(NXT))=RECORDS)                   
00738600     OR LONGSET(IDTYPE(NXT)) THEN BEGIN                                             
00738700       IF (NEXTBIT NEQ (BITSPERWORD-1)) THEN BEGIN                                  
00738800         DISPL:=*+1;                                                                
00738900         NEXTBIT:=BITSPERWORD-1;                                                    
00739000       END;                                                                         
00739100       FLDADDR(NXT):=DISPL;                                                         
00739200       IF(FORM(IDTYPE(NXT))=RECORDS) OR LONGSET(IDTYPE(NXT)) THEN BEGIN             
00739300         DISPL:=DISPL+SWORDS(IDTYPE(NXT));                                          
00739400       END ELSE BEGIN                                                               
00739500         IF(PACKED(IDTYPE(NXT))=PACKEDSTRUC) THEN BEGIN                             
00739600           DISPL:=DISPL+(SWORDS(IDTYPE(NXT))-1) DIV                                 
00739700             ELSPERWORD(IDTYPE(NXT))+1;                                             
00739800         END ELSE BEGIN                                                             
00739900           DISPL:=*+LSIZE;                                                          
00740000         END;                                                                       
00740100       END;                                                                         
00740200     END ELSE BEGIN                                                                 
00740300       BITRANGE(NXT):=LBITS;                                                        
00740400       IF(NEXTBIT < (LBITS-1)) THEN BEGIN                                           
00740500         DISPL := DISPL + 1;                                                        
00740600         NEXTBIT := BITSPERWORD -1;                                                 
00740700       END;                                                                         
00740800       FLDADDR(NXT):=DISPL;                                                         
00740900       BITADDR(NXT):=NEXTBIT;                                                       
00741000       NEXTBIT:=*-LBITS;                                                            
00741100       IF (NEXTBIT<0) THEN BEGIN                                                    
00741200         DISPL:=*+1;                                                                
00741300         NEXTBIT:=BITSPERWORD-1;                                                    
00741400       END;                                                                         
00741500     END;                                                                           
00741600   END ELSE BEGIN                                                                   
00741700     FLDADDR(NXT):=DISPL;                                                           
00741800     IF(FORM(IDTYPE(NXT))=ARRAYS) OR (FORM(IDTYPE(NXT))=RECORDS) OR                 
00741900     LONGSET(IDTYPE(NXT)) THEN BEGIN                                                
00742000       IF(FORM(IDTYPE(NXT))=RECORDS) OR LONGSET(IDTYPE(NXT)) THEN BEGIN             
00742100         DISPL:=*+SWORDS(IDTYPE(NXT));                                              
00742200       END ELSE BEGIN                                                               
00742300         IF (PACKED(IDTYPE(NXT))=PACKEDSTRUC) THEN BEGIN                            
00742400           DISPL:=DISPL+(SWORDS(IDTYPE(NXT))-1) DIV ELSPERWORD                      
00742500             (IDTYPE(NXT))+1;                                                       
00742600         END ELSE BEGIN                                                             
00742700           DISPL:=*+LSIZE;                                                          
00742800         END;                                                                       
00742900         NEXTBIT:=BITSPERWORD-1;                                                    
00743000       END;                                                                         
00743100     END ELSE BEGIN                                                                 
00743200       DISPL:=*+LSIZE;                                                              
00743300     END;                                                                           
00743400   END;                                                                             
00743500   END;   % OF FIELDADDRESS                                                         
00743600                                                                                    
00743700   %                                                                                
00743800   NXT1:=NIL; LSP:=NIL;                                                             
00743900   IF NOT SYMBOLIN(IDENTCASESET OR SEMICOLONSET OR FSYS) THEN BEGIN                 
00744000     ERROR(2385); SKIP(FSYS OR IDENTCASESET);                                       
00744100   END;                                                                             
00744200   WHILE (SYMBOL = SEMICOLON) DO INSYMBOL;                                          
00744300   WHILE (SYMBOL = IDENT) DO BEGIN                                                  
00744400     NXT:=NXT1;                                                                     
00744500     DO BEGIN                                                                       
00744600       IF (SYMBOL=IDENT) THEN BEGIN                                                 
00744700         NEWFIELDRECORDWITHNAME(LIP);                                               
00744800         IDTYPE(LIP):=NIL; NEXT(LIP):=NIL; KLASS(LIP):=FIELD;                       
00744900         PACKEDFIELD(LIP):=IF PACKEDSPEC THEN PACKEDSTRUC                           
00745000                           ELSE UNPACKEDSTRUC;                                      
00745100         IF(NXT = NIL) THEN BEGIN                                                   
00745200           NXT:=LIP;                                                                
00745300         END ELSE BEGIN                                                             
00745400           NEXT(LIP1):=LIP;                                                         
00745500         END;                                                                       
00745600         LIP1:=LIP;                                                                 
00745700         ENTERID(LIP);                                                              
00745800         INSYMBOL;                                                                  
00745900       END ELSE BEGIN                                                               
00746000         ERROR(2370);                                                               
00746100       END; % OF IF (SYMBOL=IDENT)                                                  
00746200       IF NOT SYMBOLIN(COMMACOLONSET) THEN BEGIN                                    
00746300         ERROR(2371); SKIP(FSYS OR COMMACOLONOFSEMICOLONCASESET);                   
00746400       END;                                                                         
00746500       TEST:=(SYMBOL NEQ COMMA);                                                    
00746600       IF NOT TEST THEN INSYMBOL;                                                   
00746700     END UNTIL TEST;                                                                
00746800     IF SYMBOLIN(COLONSET) THEN INSYMBOL ELSE ERROR(2372);                          
00746900     TYP((FSYS OR CASESEMICOLONSET),LSP,LSIZE,LBITS);                               
00747000     IF (FORM(LSP)=SUBRANGE) THEN BEGIN                                             
00747100       IF(NOT PACKEDSPEC) THEN BEGIN                                                
00747200         LBITS:=BITS(RANGETYPE(LSP));                                               
00747300       END;                                                                         
00747400     END;                                                                           
00747500     WHILE (NXT NEQ NIL) DO BEGIN                                                   
00747600       IDTYPE(NXT):=LSP;                                                            
00747700       FIELDADDRESS(NXT);                                                           
00747800       NXT:=NEXT(NXT);                                                              
00747900     END; % OF WHILE                                                                
00748000     IF (SYMBOL = SEMICOLON) THEN BEGIN                                             
00748100       INSYMBOL;                                                                    
00748200       IF NOT SYMBOLIN(IDENTCASESET OR ENDSET OR RPARENTSET) THEN BEGIN             
00748300         ERROR(2373); SKIP(FSYS OR IDENTCASESET);                                   
00748400       END;                                                                         
00748500     END; % OF IF                                                                   
00748600   END; % OF WHILE (SYMBOL = IDENT)                                                 
00748700   IF (SYMBOL = CASESY) THEN BEGIN                                                  
00748800     NEW(LSP,OTHERSTRUCTSIZE);                                                      
00748900     TAGFIELDP(LSP):=NIL; FSTVAR(LSP):=NIL; FORM(LSP):=TAGFLD;                      
00749000     FRECVAR:=LSP;                                                                  
00749100     INSYMBOL;                                                                      
00749200     IF (SYMBOL = IDENT) THEN BEGIN                                                 
00749300       NEWFIELDRECORDWITHNAME(LIP);                                                 
00749400       IDTYPE(LIP):=NIL; KLASS(LIP):=FIELD;                                         
00749500       NEXT(LIP):=NIL;                                                              
00749600       INSYMBOL;                                                                    
00749700       PRTERR := FALSE;                                                             
00749800       SEARCHID(TYPESET,LIP1);                                                      
00749900       PRTERR := TRUE;                                                              
00750000       IF (SYMBOL=COLON) THEN BEGIN                                                 
00750100         COLONPRES := TRUE;                                                         
00750200         ENTERID(LIP);                                                              
00750300         INSYMBOL;                                                                  
00750400       END ELSE BEGIN                                                               
00750500         COLONPRES := FALSE;                                                        
00750600         GO TO SEARCH;                                                              
00750700       END;                                                                         
00750800       IF (SYMBOL = IDENT) THEN BEGIN                                               
00750900         SEARCHID(TYPESET,LIP1);                                                    
00751000 SEARCH:                                                                            
00751100         LSP1:=IDTYPE(LIP1);                                                        
00751200         IF (LSP1 NEQ NIL) THEN BEGIN                                               
00751300           IF (FORM(LSP1) <= SUBRANGE) OR STRING(LSP1) THEN BEGIN                   
00751400             IF COMPTYPES(REALPTR,LSP1) THEN BEGIN                                  
00751500               ERROR(2375);                                                         
00751600             END ELSE IF STRING(LSP1) THEN BEGIN                                    
00751700               ERROR(2376);                                                         
00751800             END;                                                                   
00751900             IDTYPE(LIP):=LSP1; TAGFIELDP(LSP):=LIP;                                
00752000             IF COLONPRES THEN BEGIN                                                
00752100               LSIZE:=SWORDS(LSP1); LBITS:=BITS(LSP1);                              
00752200               FIELDADDRESS(LIP);                                                   
00752300             END;                                                                   
00752400           END ELSE BEGIN                                                           
00752500             ERROR(2377);                                                           
00752600           END; % OF IF FORMS...                                                    
00752700         END; % OF IF (LSP1 = NIL)                                                  
00752800         IF COLONPRES THEN BEGIN                                                    
00752900           INSYMBOL;                                                                
00753000         END;                                                                       
00753100       END ELSE BEGIN                                                               
00753200         ERROR(2378); SKIP(FSYS OR OFLPARENTSET);                                   
00753300       END; % OF IF (SYMBOL = IDENT)                                                
00753400     END ELSE BEGIN                                                                 
00753500       ERROR(2386); SKIP(FSYS OR OFLPARENTSET);                                     
00753600     END; % OF IF (SYMBOL = IDENT)                                                  
00753700     SWORDS(LSP):=DISPL;                                                            
00753800     IF (SYMBOL = OFSY) THEN INSYMBOL ELSE ERROR(2384);                             
00753900     LSP1:=NIL; MINSIZE:=MAXSIZE:=DISPL; TAGBIT := NEXTBIT;                         
00754000     DO BEGIN                                                                       
00754100       LSP2:=NIL;                                                                   
00754200       DO BEGIN                                                                     
00754300         CONSTANT((FSYS OR COMMACOLONLPARENTSET),LSP3,LVALUE);                      
00754400         IF (TAGFIELDP(LSP) NEQ NIL) THEN BEGIN                                     
00754500           IF NOT COMPTYPES(IDTYPE(TAGFIELDP(LSP)),LSP3) THEN BEGIN                 
00754600             ERROR(2379);                                                           
00754700           END;                                                                     
00754800         END;                                                                       
00754900         NEW(LSP3,OTHERSTRUCTSIZE);                                                 
00755000         NXTVAR(LSP3):=LSP1; SUBVAR(LSP3):=LSP2;                                    
00755100         VARVAL(LSP3):=LVALUE; FORM(LSP3):=VARIANT;                                 
00755200         LSP1:=LSP3; LSP2:=LSP3;                                                    
00755300         TEST:=(SYMBOL NEQ COMMA);                                                  
00755400         IF NOT TEST THEN INSYMBOL;                                                 
00755500       END UNTIL TEST;                                                              
00755600       IF (SYMBOL = COLON) THEN INSYMBOL ELSE ERROR(2380);                          
00755700       IF (SYMBOL = LPARENT) THEN INSYMBOL ELSE ERROR(2381);                        
00755800       FIELDLIST((FSYS OR RPARENTSEMICOLONSET),LSP2);                               
00755900       IF (DISPL > MAXSIZE) THEN MAXSIZE:=DISPL;                                    
00756000       WHILE (LSP3 NEQ NIL) DO BEGIN                                                
00756100         LSP4:=SUBVAR(LSP3); SUBVAR(LSP3):=LSP2;                                    
00756200         SWORDS(LSP3):=DISPL;                                                       
00756300         LSP3:=LSP4;                                                                
00756400       END;                                                                         
00756500       IF (SYMBOL = RPARENT) THEN BEGIN                                             
00756600         INSYMBOL;                                                                  
00756700         IF NOT SYMBOLIN(FSYS OR SEMICOLONSET) THEN BEGIN                           
00756800           ERROR(2382); SKIP(FSYS OR SEMICOLONSET);                                 
00756900         END;                                                                       
00757000       END ELSE BEGIN                                                               
00757100         ERROR(2383);                                                               
00757200       END;                                                                         
00757300       TEST:=(SYMBOL NEQ SEMICOLON);                                                
00757400       IF NOT TEST THEN BEGIN                                                       
00757500         DISPL:=MINSIZE;                                                            
00757600         NEXTBIT := TAGBIT;                                                         
00757700         INSYMBOL;                                                                  
00757800       END;                                                                         
00757900     END UNTIL TEST OR (SYMBOL = ENDSY);                                            
00758000     DISPL:=MAXSIZE;                                                                
00758100     FSTVAR(LSP):=LSP1;                                                             
00758200   END ELSE BEGIN                                                                   
00758300     FRECVAR:=NIL;                                                                  
00758400     IF (NEXTBIT NEQ (BITSPERWORD-1)) THEN BEGIN                                    
00758500       DISPL:=*+1;                                                                  
00758600     END;                                                                           
00758700   END;                                                                             
00758800 END; % OF FIELDLIST                                                                
00758900                                                                                    
00759000                                                                                    
00759100                                                                                    
00759200   % BODY OF TYP                                                                    
00759300   %         ***                                                                    
00759400   IF NOT SYMBOLIN(TYPEBEGSYS) THEN BEGIN                                           
00759500     ERROR(2350); SKIP(FSYS OR TYPEBEGSYS);                                         
00759600   END;                                                                             
00759700   IF SYMBOLIN(TYPEBEGSYS) THEN BEGIN                                               
00759800                                                   % SIMPLE (SCALAR) TYPE           
00759900     IF SYMBOLIN(SIMPTYPEBEGSYS) THEN BEGIN                                         
00760000       SIMPLETYPE(FSYS,FSP,FSIZE,FBITS);                                            
00760100                                                   % POINTER TYPE                   
00760200     END ELSE IF (SYMBOL = ARROW) THEN BEGIN                                        
00760300       NEW(LSP,OTHERSTRUCTSIZE); FSP:=LSP;                                          
00760400       ELTYPE(LSP):=NIL; SWORDS(LSP):=PTRSIZE; FORM(LSP):=POINTERS;                 
00760500       BITS(LSP):=PTRBITSIZE;                                                       
00760600       INSYMBOL;                                                                    
00760700       IF (SYMBOL = IDENT) THEN BEGIN                                               
00760800         SEARCHFWDCHAIN(LCP);                                                       
00760900         IF ((LCP = NIL)OR (VLEV(LCP) NEQ LEXLEVEL)) THEN BEGIN                     
00761000           NEWIDENTRECORDWITHNAME(LCP);                                             
00761100           IDTYPE(LCP):=LSP; NEXT(LCP):=FWPTR; KLASS(LCP):=TYPES;                   
00761200           FWPTR:=LCP;                                                              
00761300         END ELSE BEGIN                                                             
00761400           IF (IDTYPE(LCP) NEQ NIL) THEN BEGIN                                      
00761500             IF (FORM(IDTYPE(LCP)) = FILES) THEN BEGIN                              
00761600               ERROR(2351);                                                         
00761700             END ELSE BEGIN                                                         
00761800               ELTYPE(LSP):=IDTYPE(LCP);                                            
00761900             END;                                                                   
00762000           END; % OF IF IDTYPE...                                                   
00762100         END; % OF IF (LCP=NIL)                                                     
00762200         INSYMBOL;                                                                  
00762300       END ELSE BEGIN                                                               
00762400         ERROR(2352);                                                               
00762500       END; % OF IF (SYMBOL=IDENT)                                                  
00762600                                                 % ALL OTHER TYPES MAY BE           
00762700                                                 %   PRECEDED BY -PACKED-           
00762800     END ELSE BEGIN                                                                 
00762900                                                   % PACKED                         
00763000       IF (SYMBOL = PACKEDSY) THEN BEGIN                                            
00763100         INSYMBOL;                                                                  
00763200         IF NOT SYMBOLIN(TYPEDELS) THEN BEGIN                                       
00763300           ERROR(2353); SKIP(FSYS OR TYPEDELS);                                     
00763400         END;                                                                       
00763500         PACKEDSPEC:=TRUE;                                                          
00763600       END ELSE BEGIN                                                               
00763700         PACKEDSPEC:=FALSE;                                                         
00763800       END; % OF PACKED                                                             
00763900                                                   % ARRAYS                         
00764000       IF (SYMBOL = ARRAYSY) THEN BEGIN                                             
00764100         INSYMBOL;                                                                  
00764200         IF (SYMBOL = LBRACK) THEN INSYMBOL ELSE ERROR(2354);                       
00764300         LSP1:=NIL;                                                                 
00764400         DO BEGIN                                                                   
00764500           NEW(LSP,OTHERSTRUCTSIZE);                                                
00764600           AELTYPE(LSP):=LSP1; INXTYPE(LSP):=NIL; FORM(LSP):=ARRAYS;                
00764700           PACKED(LSP):=IF PACKEDSPEC THEN PACKEDSTRUC ELSE UNPACKEDSTRUC           
00764800           ;                                                                        
00764900           LSP1:=LSP;                                                               
00765000           SIMPLETYPE((FSYS OR COMMARBRACKOFSET),LSP2,LSIZE,LBITS);                 
00765100           SWORDS(LSP1):=LSIZE;                                                     
00765200           IF (LSP2 NEQ NIL) THEN BEGIN                                             
00765300             IF (FORM(LSP2) <= SUBRANGE) THEN BEGIN                                 
00765400               IF (LSP2 = REALPTR) THEN BEGIN                                       
00765500                 ERROR(2355); LSP2:=NIL;                                            
00765600               END ELSE IF (LSP2 = INTPTR) THEN BEGIN                               
00765700                 ERROR(2356); LSP2:=NIL;                                            
00765800               END;                                                                 
00765900               INXTYPE(LSP):=LSP2;                                                  
00766000             END ELSE BEGIN                                                         
00766100               ERROR(2357); LSP2:=NIL;                                              
00766200             END; % OF IF FORM...                                                   
00766300           END; % OF IF (LSP2 NEQ NIL)                                              
00766400           TEST:=(SYMBOL NEQ COMMA);                                                
00766500           IF NOT TEST THEN INSYMBOL;                                               
00766600         END UNTIL TEST;                                                            
00766700         IF (SYMBOL = RBRACK) THEN INSYMBOL ELSE ERROR(2358);                       
00766800         IF (SYMBOL = OFSY) THEN INSYMBOL ELSE ERROR(2359);                         
00766900         TYP(FSYS,LSP,LSIZE,LBITS);                                                 
00767000         IF (FORM(LSP)=SUBRANGE) THEN BEGIN                                         
00767100           IF(NOT PACKEDSPEC) THEN BEGIN                                            
00767200             LBITS:=BITS(RANGETYPE(LSP));                                           
00767300           END;                                                                     
00767400         END;                                                                       
00767500         IF((LBITS < BITSPERWORD) AND(NOT PACKEDSPEC)) THEN                         
00767600         BEGIN                                                                      
00767700           LBITS:=BITSPERWORD;                                                      
00767800         END;                                                                       
00767900         IF (LBITS>8) THEN LBITS := BITSPERWORD                                     
00768000         ELSE IF (LBITS>6) THEN LBITS:=8                                            
00768100              ELSE IF (LBITS>4) THEN LBITS:=6                                       
00768200                   ELSE IF (LBITS>1) THEN LBITS :=4                                 
00768300                        ELSE LBITS :=LBITS;                                         
00768400         DO BEGIN                                                                   
00768500           IF(FORM(LSP)=ARRAYS) THEN BEGIN                                          
00768600             IF(PACKED(LSP)=PACKEDSTRUC) THEN BEGIN                                 
00768700               LSIZE:=(LSIZE+ELSPERWORD(LSP)-1) DIV ELSPERWORD(LSP);                
00768800               LBITS:=BITSPERWORD;                                                  
00768900             END;                                                                   
00769000           END;                                                                     
00769100           LSP2:=AELTYPE(LSP1); AELTYPE(LSP1):=LSP;                                 
00769200           IF (INXTYPE(LSP1) NEQ NIL) THEN BEGIN                                    
00769300             GETBOUNDS(INXTYPE(LSP1),LMIN,LMAX);                                    
00769400             LSIZE:=LSIZE * (LMAX-LMIN+1);                                          
00769500             BITS(LSP1):=LBITS;                                                     
00769600             SWORDS(LSP1):=LSIZE;                                                   
00769700             ELSPERWORD(LSP1):=IF(PACKED(LSP1)=UNPACKEDSTRUC) THEN 1                
00769800                               ELSE IF(LBITS=48) THEN 1                             
00769900                                    ELSE IF(LBITS=8) THEN 6                         
00770000                                         ELSE IF(LBITS=6) THEN 8                    
00770100                                              ELSE IF(LBITS=4) THEN 12              
00770200                                                   ELSE 48;                         
00770300           END;                                                                     
00770400           LSP:=LSP1; LSP1:=LSP2;                                                   
00770500         END UNTIL (LSP1 = NIL);                                                    
00770600                                                   % RECORDS                        
00770700       END ELSE IF (SYMBOL = RECORDSY) THEN BEGIN                                   
00770800         INSYMBOL;                                                                  
00770900         OLDTOP:=TOP;                                                               
00771000         IF (TOP < MAXTOP) THEN BEGIN                                               
00771100           TOP:=TOP+DISPLAYSIZE;                                                    
00771200           FNAME(TOP):=NIL; FLABEL(TOP):=NIL; OCCUR(TOP):=REC;                      
00771300         END ELSE BEGIN                                                             
00771400           ERROR(2360);                                                             
00771500         END;                                                                       
00771600         DISPL:=0; NEXTBIT :=BITSPERWORD-1;                                         
00771700         FIELDLIST(((FSYS AND NOT(SEMICOLONSET)) OR ENDSET),LSP1);                  
00771800         NEW(LSP,OTHERSTRUCTSIZE);                                                  
00771900         FSTFLD(LSP):=FNAME(TOP); RECVAR(LSP):=LSP1;                                
00772000         SWORDS(LSP):=DISPL; FORM(LSP):=RECORDS;                                    
00772100         BITS(LSP):=BITSPERWORD;                                                    
00772200         PACKED(LSP):=IF PACKEDSPEC THEN PACKEDSTRUC ELSE UNPACKEDSTRUC;            
00772300         TOP:=OLDTOP;                                                               
00772400         IF (SYMBOL = ENDSY) THEN INSYMBOL ELSE ERROR(2361);                        
00772500                                                   % SETS                           
00772600       END ELSE IF (SYMBOL = SETSY) THEN BEGIN                                      
00772700         INSYMBOL;                                                                  
00772800         IF (SYMBOL = OFSY) THEN INSYMBOL ELSE ERROR(2362);                         
00772900         SIMPLETYPE(FSYS,LSP1,LSIZE,LBITS);                                         
00773000         IF (LSP1 NEQ NIL) THEN BEGIN                                               
00773100           IF (FORM(LSP1) > SUBRANGE) THEN BEGIN                                    
00773200             ERROR(2363); LSP1:=NIL;                                                
00773300           END ELSE BEGIN                                                           
00773400             IF (LSP1 = REALPTR) OR (LSP1=INTPTR) THEN BEGIN                        
00773500               ERROR(2364);                                                         
00773600             END;                                                                   
00773700           END;                                                                     
00773800         END;                                                                       
00773900         NEW(LSP,OTHERSTRUCTSIZE);                                                  
00774000         ELSET(LSP):=LSP1;  FORM(LSP):=POWER;                                       
00774100         GETBOUNDS(LSP1,LMIN,LMAX);                                                 
00774200         IF (LMIN>=0) AND (LMAX<=BITSPERWORD-1) THEN BEGIN                          
00774300           SWORDS(LSP):=SETSIZE;                                                    
00774400         END ELSE BEGIN                                                             
00774500           IF (LMAX * LMIN < 0) THEN LMAX := *+1;                                   
00774600           IF (LMAX-LMIN > MAXSETSIZE) AND (LSP1 NEQ CHARPTR) THEN BEGIN            
00774700             ERROR(2430);                                                           
00774800             LSIZE := MAXSETSIZE DIV BITSPERWORD + 1;                               
00774900           END ELSE BEGIN                                                           
00775000             LSIZE := (LMAX-LMIN+BITSPERWORD) DIV BITSPERWORD;                      
00775100           END;                                                                     
00775200           SWORDS(LSP):=LSIZE;                                                      
00775300         END;                                                                       
00775400         SETTYPE(LSP) := IF ((SWORDS(LSP)>1) OR (LMIN<0)) THEN LSET                 
00775500                         ELSE SSET;                                                 
00775600         BITS(LSP):=SETBITSIZE;                                                     
00775700         PACKED(LSP):=IF PACKEDSPEC THEN PACKEDSTRUC ELSE UNPACKEDSTRUC;            
00775800                                                   % FILES                          
00775900       END ELSE IF (SYMBOL = FILESY) THEN BEGIN                                     
00776000         INSYMBOL;                                                                  
00776100         FILEATTRIBUTES;                                                            
00776200         NEW(LSP,OTHERSTRUCTSIZE);                                                  
00776300         SWORDS(LSP) := ATTSIZE;                                                    
00776400         FORM(LSP) := FILES;                                                        
00776500         NEW(LSP1,ATTSIZE);                                                         
00776600         REPLACE POINTER(HEAP[LSP1]) BY FILEATTS FOR ATTSIZE WORDS;                 
00776700         IF (SYMBOL = OFSY) THEN INSYMBOL ELSE ERROR(2365);                         
00776800         TYP(FSYS,LSP1,LSIZE,LBITS);                                                
00776900         FILTYPE(LSP) := LSP1;    %PTR TO RECORD STRUCTURE                          
00777000         TEXTFILE(LSP):=IF(PACKEDSPEC AND COMPTYPES(CHARPTR,LSP1)) THEN             
00777100           TEXTFIL ELSE NOTEXTFIL;                                                  
00777200         IF(TEXTFILE(LSP) = TEXTFIL) THEN PACKED(LSP):=PACKEDSTRUC                  
00777300         ELSE PACKED(LSP):=REAL(PACKEDSPEC);                                        
00777400         IF NOT STANDARDTOG THEN BEGIN                                              
00777500           IF(MAXREC*(IF(AELTYPE(LSP1)=CHARPTR) THEN CHARSPERWORD ELSE 1)           
00777600             < (LSIZE)) THEN ERROR(2367);                                           
00777700         END;                                                                       
00777800         IF NOT(FORM(LSP1)=ARRAYS OR FORM(LSP1)=RECORDS                             
00777900           OR LSP1=CHARPTR OR LSP1=REALPTR OR LSP1=INTPTR                           
00778000           OR LSP1=BOOLPTR) THEN BEGIN                                              
00778100           ERROR(2369);                                                             
00778200         END;                                                                       
00778300       END;                                                                         
00778400       FSP:=LSP;                                                                    
00778500     END; % OF ALL POSSIBLY PACKED TYPES                                            
00778600     IF NOT SYMBOLIN(FSYS) THEN BEGIN                                               
00778700       ERROR(2366); SKIP(FSYS);                                                     
00778800     END;                                                                           
00778900   END ELSE BEGIN                                                                   
00779000     FSP:=NIL;                                                                      
00779100   END;                                                                             
00779200   IF (FSP=NIL) THEN BEGIN                                                          
00779300     FBITS:=BITSPERWORD;                                                            
00779400     FSIZE:=1;                                                                      
00779500   END ELSE BEGIN                                                                   
00779600     FSIZE:=SWORDS(FSP);                                                            
00779700     FBITS:=BITS(FSP);                                                              
00779800   END;                                                                             
00779900 END; % OF TYPE DECLARATIONS                                                        
00780000                                                                                    
00780100                                                                                    
00780200 % TYPE DECLARATION PART ************************************************           
00780300 %=======================================================================           
00780400 % STANDARD PROCEDURES FOR CREATING STACK BUILDING RECORDS                          
00780500 %=======================================================================           
00780600                                                                                    
00780700 PROCEDURE GENERATEONEWORD(FID);                                                    
00780800         VALUE FID;                                                                 
00780900         TYPEIDENTPTR FID;                                                          
00781000         BEGIN                                                                      
00781100           INTEGER P;                                                               
00781200           NEW(P,OTHERTHINGSIZE);                                                   
00781300           BUILDKIND(P):=ONEWORD;                                                   
00781400           BUILDID(P):=FID;                                                         
00781500           LINKINTOSTACK(P);                                                        
00781600         END;                                                                       
00781700                                                                                    
00781800 PROCEDURE GENERATEARRAYDESCRIPTOR(FSIZE,FID);                                      
00781900         VALUE FSIZE,FID;                                                           
00782000         INTEGER FSIZE;                                                             
00782100         TYPEIDENTPTR FID;                                                          
00782200         BEGIN                                                                      
00782300           INTEGER P;                                                               
00782400           NEW(P,DESCPCWSIZE);                                                      
00782500           BUILDKIND(P):=ARRAYDESCRIPTOR;                                           
00782600           BUILDVAL(P):= 0 & FSIZE [39:20];                                         
00782700           BUILDID(P):=FID;                                                         
00782800           IF (FSIZE > 512) THEN BUILDVAL(P):=BUILDVAL(P) & 1 [44:01];              
00782900           TAGSIXFLAG:=TRUE;                                                        
00783000           LINKINTOSTACK(P);                                                        
00783100           ARRAYCELLS[LEXLEVEL] := *+FSIZE;  %FOR CORE ESTIMATE                     
00783200         END;                                                                       
00783300                                                                                    
00783400 PROCEDURE GENERATESZDESCRIPTOR(FSIZE,FSZ,FID);                                     
00783500         VALUE FSIZE,FSZ,FID;                                                       
00783600         INTEGER FSIZE,FSZ;                                                         
00783700         TYPEIDENTPTR FID;                                                          
00783800         BEGIN                                                                      
00783900           INTEGER P;                                                               
00784000           NEW(P,DESCPCWSIZE);                                                      
00784100           BUILDKIND(P):=ARRAYDESCRIPTOR;                                           
00784200           BUILDVAL(P):= 0 & FSIZE [39:20]                                          
00784300                           & FSZ   [42:03];                                         
00784400           BUILDID(P):=FID;                                                         
00784500           IF (FSIZE > 512) THEN BUILDVAL(P):=BUILDVAL(P) & 1 [44:01];              
00784600           TAGSIXFLAG:=TRUE;                                                        
00784700           LINKINTOSTACK(P);                                                        
00784800         END;                                                                       
00784900                                                                                    
00785000 PROCEDURE GENERATEFPBDESCRIPTOR(FSIZE,INDEX,FID);                                  
00785100         VALUE FSIZE,INDEX,FID;                                                     
00785200         INTEGER FSIZE,INDEX;                                                       
00785300         TYPEIDENTPTR FID;                                                          
00785400         BEGIN                                                                      
00785500           INTEGER P;                                                               
00785600           NEW(P,DESCPCWSIZE);                                                      
00785700           BUILDKIND(P):=FPBDESCRIPTOR;                                             
00785800           BUILDVAL(P):= 0 & FSIZE [39:20]                                          
00785900                        & INDEX [19:20]                                             
00786000                        & 1     [19:02]                                             
00786100                        & 7     [42:03]                                             
00786200                        & 1     [45:01];                                            
00786300           BUILDID(P):=FID;                                                         
00786400           TAGSIXFLAG:=TRUE;                                                        
00786500           LINKINTOSTACK(P);                                                        
00786600         END;                                                                       
00786700                                                                                    
00786800 PROCEDURE GENERATEPCWWORD(PCW,FID);                                                
00786900         VALUE PCW,FID;                                                             
00787000         REAL PCW;                                                                  
00787100         TYPEIDENTPTR FID;                                                          
00787200         BEGIN                                                                      
00787300           INTEGER P;                                                               
00787400           TYPEIDENTPTR LID;                                                        
00787500           WHILE DECLAREDLC<LCMAX DO BEGIN                                          
00787600             NEWTEMPVAR(LID);                                                       
00787700             VLEV(LID):=LEXLEVEL;  VADDR(LID):=DECLAREDLC;                          
00787800             GENERATEONEWORD(LID);                                                  
00787900             DECLAREDLC := *+1;                                                     
00788000           END;                                                                     
00788100           LC := LCMAX;                                                             
00788200           NEW(P,DESCPCWSIZE);                                                      
00788300           BUILDKIND(P):=PCWWORD;                                                   
00788400           BUILDVAL(P):=PCW & 0 [47:01];                                            
00788500           BUILDID(P):=FID;                                                         
00788600           LINKINTOSTACK(P);                                                        
00788700           LCMAX := *+1;                                                            
00788800           DECLAREDLC := LCMAX;                                                     
00788900         END;                                                                       
00789000                                                                                    
00789100 PROCEDURE GENERATEFUNNYSIRW;                                                       
00789200         BEGIN                                                                      
00789300           INTEGER P;                                                               
00789400           NEW(P,OTHERTHINGSIZE);                                                   
00789500           BUILDKIND(P):=FUNNYSIRW;                                                 
00789600           BUILDID(P):=NIL;                                                         
00789700           LINKINTOSTACK(P);                                                        
00789800         END;                                                                       
00789900                                                                                    
00790000 PROCEDURE GENERATESTATSARRAY;                                                      
00790100     BEGIN                                                                          
00790200       INTEGER P;                                                                   
00790300       TYPEIDENTPTR LIP;                                                            
00790400       NEWTEMPARR(LIP);                                                             
00790500       VLEV(LIP):=LEXLEVEL;  VADDR(LIP):=LC;                                        
00790600       NEW(P,OTHERTHINGSIZE);                                                       
00790700       BUILDKIND(P):=STATSARRAY;                                                    
00790800       BUILDID(P):=LIP;                                                             
00790900       LINKINTOSTACK(P);                                                            
00791000     END;                                                                           
00791100                                                                                    
00791200 PROCEDURE GENERATEONEWORDCONSTANT(VAL,FID);                                        
00791300     VALUE VAL,FID; REAL VAL;                                                       
00791400     TYPEIDENTPTR FID;                                                              
00791500     BEGIN                                                                          
00791600       INTEGER P;                                                                   
00791700       NEW(P,DESCPCWSIZE);                                                          
00791800       BUILDKIND(P):=ONEWORDCONSTANT;                                               
00791900       BUILDVAL(P):=VAL;                                                            
00792000           BUILDID(P):=FID;                                                         
00792100       LINKINTOSTACK(P);                                                            
00792200     END;                                                                           
00792300                                                                                    
00792400 PROCEDURE STATISTICSCODE(FUNC,DISP);                                               
00792500 %         **************                                                           
00792600 VALUE FUNC,DISP;                                                                   
00792700 INTEGER FUNC,DISP;                                                                 
00792800 %-----------------------------------------------------------------------           
00792900 %                                                                                  
00793000 %       FUNC=0 USED AT PROCEDURE ENTRY                                             
00793100 %       FUNC=1 USED AT PROC EXIT OR BEFORE A CALL                                  
00793200 %       FUNC=2 USED AFTER A CALL                                                   
00793300 %                                                                                  
00793400 %       DISP: DISPLACEMENT OF STATS DESCRIPTOR IN D2 STACK                         
00793500 %                                                                                  
00793600 %-----------------------------------------------------------------------           
00793700 BEGIN                                                                              
00793800   IF LCODE THEN BEGIN                                                              
00793900     REPLACE LBUF[59] BY ">" FOR 6,                                                 
00794000         "STATS ","CODE F","OLLOWS";                                                
00794100     WRITELBUFFER;                                                                  
00794200   END;                                                                             
00794300   IF (FUNC = 0) THEN BEGIN                                                         
00794400     % INCREMENT COUNTER WORD                                                       
00794500     GENV(NAMC,2,DISP); GENOP(ZERO); GENOP(INDX);                                   
00794600     GENOP(DUPL); GENOP(LOAD);                                                      
00794700     GENOP(ONE); GENOP(ADD); GENOP(STOD);                                           
00794800   END;                                                                             
00794900   % INDEX THE TIMING WORD                                                          
00795000   GENV(NAMC,2,DISP); GENOP(ONE); GENOP(INDX);                                      
00795100   GENOP(DUPL); GENOP(LOAD);                                                        
00795200   % READ CLOCK                                                                     
00795300   GENOP(MKST);GENV(NAMC,0,24);GENOP1(LT8,12);GENOP(ENTR);                          
00795400   % ADJUST WORD BY CLOCK                                                           
00795500   GENOP(IF (FUNC = 1) THEN ADD ELSE SUBT);                                         
00795600   GENOP(STOD);                                                                     
00795700   IF LCODE THEN BEGIN                                                              
00795800     REPLACE LBUF[59] BY ">" FOR 6,                                                 
00795900         "END ST","ATS CO","DE";                                                    
00796000     WRITELBUFFER;                                                                  
00796100   END;                                                                             
00796200 END;                                                                               
00796300                                                                                    
00796400                                                                                    
00796500 DEFINE CHECKIN(FSYS,ERRNO)=                                                        
00796600 %      *******                                                                     
00796700         BEGIN                                                                      
00796800           IF NOT SYMBOLIN(FSYS) THEN BEGIN                                         
00796900             ERROR(ERRNO); SKIP(FSYS);                                              
00797000           END;                                                                     
00797100         END#;                                                                      
00797200                                                                                    
00797300 PROCEDURE ENTERFWDREFS(FWDPTR);                                                    
00797400 %         ************                                                             
00797500 TYPEIDENTPTR                                                                       
00797600   FWDPTR;                                                                          
00797700 BEGIN                                                                              
00797800 TYPEIDENTPTR                                                                       
00797900   LCP,LCP1,LCP2,PTR;                                                               
00798000 LABEL EXIT;                                                                        
00798100 POINTER P,P2;                                                                      
00798200 INTEGER L,LENG;                                                                    
00798300 IF (FWDPTR NEQ NIL) THEN BEGIN                                                     
00798400   LCP:=FWDPTR;                                                                     
00798500   WHILE (LCP NEQ NIL) DO BEGIN                                                     
00798600     P2:=POINTER(HEAP[NAME(LCP)]);                                                  
00798700     LENG := REAL(P2,1);                                                            
00798800     P2:=P2+1;                                                                      
00798900     FOR DISX:=TOP DOWNTO 0 DO BEGIN                                                
00799000       PTR:=FNAME(DISX);                                                            
00799100       WHILE(PTR NEQ NIL) DO BEGIN                                                  
00799200         P:=POINTER(HEAP[NAME(PTR)]);                                               
00799300         L:=MIN(REAL(P,1),LENG);                                                    
00799400         P:=P+1;                                                                    
00799500         IF (P<=P2 FOR L) THEN BEGIN                                                
00799600           IF (P=P2 FOR L) THEN BEGIN                                               
00799700             IF(INTEST(KLASS(PTR),TYPESET)) THEN BEGIN                              
00799800               GO TO EXIT;                                                          
00799900             END;                                                                   
00800000           END;                                                                     
00800100           PTR:=RLINK(PTR);                                                         
00800200         END ELSE BEGIN                                                             
00800300           PTR:=LLINK(PTR);                                                         
00800400         END;    %OF IF P                                                           
00800500       END;   %OF WHILE                                                             
00800600     END;   %OF FOR                                                                 
00800700     EXIT:                                                                          
00800800     LCP1:=PTR;                                                                     
00800900     DISX:=0;                                                                       
00801000     IF (LCP1 NEQ NIL) THEN BEGIN                                                   
00801100       IF (IDTYPE(LCP1) NEQ NIL) THEN BEGIN                                         
00801200         IF (FORM(IDTYPE(LCP1))=FILES) THEN BEGIN                                   
00801300           ERROR(2351);                                                             
00801400         END ELSE BEGIN                                                             
00801500            ELTYPE(IDTYPE(LCP)) := IDTYPE(LCP1);                                    
00801600         END;                                                                       
00801700       END;                                                                         
00801800       IF (LCP=FWDPTR) THEN BEGIN                                                   
00801900         FWDPTR:=NEXT(LCP);                                                         
00802000       END ELSE BEGIN                                                               
00802100         NEXT(LCP2):=NEXT(LCP);                                                     
00802200       END;                                                                         
00802300     END;                                                                           
00802400     LCP2:=LCP;                                                                     
00802500     LCP:=NEXT(LCP);                                                                
00802600   END;   %OF WHILE                                                                 
00802700 END;   %OF IF                                                                      
00802800 END;   %OF ENTERFWDREFS                                                            
00802900                                                                                    
00803000                                                                                    
00803100 PROCEDURE CONSTDECLARATION;                                                        
00803200 %         ****************                                                         
00803300 BEGIN                                                                              
00803400   TYPEIDENTPTR LCP;                                                                
00803500   TYPESTRUCTPTR LSP;                                                               
00803600   REAL LVALU;                                                                      
00803700   %                                                                                
00803800   IF (SYMBOL NEQ IDENT) THEN BEGIN                                                 
00803900     ERROR(2300); SKIP(FSYS OR IDENTSET);                                           
00804000   END;                                                                             
00804100   WHILE (SYMBOL = IDENT) DO BEGIN                                                  
00804200     NEWIDENTRECORDWITHNAME(LCP);                                                   
00804300     IDTYPE(LCP):=NIL; NEXT(LCP):=NIL; KLASS(LCP):=KONST;                           
00804400     INSYMBOL;                                                                      
00804500     IF (SYMBOL = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(2301);            
00804600     CONSTANT((FSYS OR SEMICOLONSET),LSP,LVALU);                                    
00804700     IDTYPE(LCP):=LSP;                                                              
00804800     ENTERID(LCP);                                                                  
00804900     IF STRING(LSP) THEN BEGIN                                                      
00805000       VLEV(LCP):=GVLEVEL; VADDR(LCP):=GDPLMT;                                      
00805100       VD1OFFSET(LCP):=GIDPLMT;                                                     
00805200     END ELSE BEGIN                                                                 
00805300       VALUES(LCP):=LVALU;                                                          
00805400     END;                                                                           
00805500     IF (SYMBOL = SEMICOLON) THEN BEGIN                                             
00805600       INSYMBOL;                                                                    
00805700       CHECKIN((FSYS OR IDENTSET),2302);                                            
00805800     END ELSE BEGIN                                                                 
00805900       ERROR(2303);                                                                 
00806000     END;                                                                           
00806100   END; % OF WHILE                                                                  
00806200 END; % OF CONSTDECLARATION                                                         
00806300                                                                                    
00806400                                                                                    
00806500 PROCEDURE LABELDECLARATION;                                                        
00806600 %         ****************                                                         
00806700 BEGIN                                                                              
00806800   TYPELBP LLP;                                                                     
00806900   BOOLEAN REDEF;                                                                   
00807000   INTEGER LBNAME;                                                                  
00807100   %                                                                                
00807200   DO BEGIN                                                                         
00807300     IF (SYMBOL = INTCONST) THEN BEGIN                                              
00807400       IF (VAL <= 9999) THEN BEGIN                                                  
00807500         LLP:=FLABEL(TOP); REDEF:=FALSE;                                            
00807600           WHILE (LLP NEQ NIL) AND NOT REDEF DO BEGIN                               
00807700             IF (LABVAL(LLP) NEQ VAL) THEN BEGIN                                    
00807800               LLP:=NEXTLAB(LLP);                                                   
00807900             END ELSE BEGIN                                                         
00808000               REDEF:=TRUE; ERROR(2310);                                            
00808100             END;                                                                   
00808200           END; % OF WHILE                                                          
00808300           IF NOT REDEF THEN BEGIN                                                  
00808400             NEW(LLP,LABELSIZE);                                                    
00808500             LABVAL(LLP):=VAL; LBNAME:=MAKELABEL;                                   
00808600             DEFINED(LLP):=REAL(FALSE); NEXTLAB(LLP):=FLABEL(TOP);                  
00808700             LABNAME(LLP):=LBNAME;                                                  
00808800             FLABEL(TOP):=LLP;                                                      
00808900             LABLEV(LLP):=LEXLEVEL;                                                 
00809000             LABADDR(LLP):=LC;                                                      
00809100             DECLAREDLC:=LCMAX:=LC;                                                 
00809200             GENERATEPCWWORD(0,NIL);                                                
00809300             LC:=LC+1;                                                              
00809400             STACKPCW(LLP):=STACKTAILP;                                             
00809500           END;                                                                     
00809600           INSYMBOL;                                                                
00809700       END ELSE BEGIN                                                               
00809800         ERROR(2314);                                                               
00809900       END;                                                                         
00810000     END ELSE BEGIN                                                                 
00810100       ERROR(2311);                                                                 
00810200     END;                                                                           
00810300     CHECKIN((FSYS OR COMMASEMICOLONSET),2312);                                     
00810400     TEST:=(SYMBOL NEQ COMMA);                                                      
00810500     IF NOT TEST THEN INSYMBOL;                                                     
00810600   END UNTIL TEST;                                                                  
00810700   IF (SYMBOL = SEMICOLON) THEN INSYMBOL ELSE ERROR(2313);                          
00810800 END; % OF LABEL DECLARATION                                                        
00810900                                                                                    
00811000                                                                                    
00811100 PROCEDURE TYPEDECLARATION;                                                         
00811200 %         ***************                                                          
00811300 BEGIN                                                                              
00811400   TYPEIDENTPTR LCP,LCP1,LCP2;                                                      
00811500   TYPESTRUCTPTR LSP;                                                               
00811600   TYPEADDRRANGE LSIZE,LBITS;                                                       
00811700   POINTER NPTR1,NPTR2;                                                             
00811800   INTEGER NLENGTH;                                                                 
00811900   %                                                                                
00812000   IF (SYMBOL NEQ IDENT) THEN BEGIN                                                 
00812100     ERROR(2320); SKIP(FSYS OR IDENTSET);                                           
00812200   END;                                                                             
00812300   WHILE (SYMBOL = IDENT) DO BEGIN                                                  
00812400     NEWIDENTRECORDWITHNAME(LCP);                                                   
00812500     IDTYPE(LCP):=NIL; KLASS(LCP):=TYPES;                                           
00812600     INSYMBOL;                                                                      
00812700     IF (SYMBOL = RELOP) AND (OP = EQOP)                                            
00812800         THEN INSYMBOL ELSE ERROR(2321);                                            
00812900     TYP((FSYS OR SEMICOLONSET),LSP,LSIZE,LBITS);                                   
00813000     %   RECORD NOT ENTERED UNTIL AFTER TYP SO THAT                                 
00813100     %   POINTER REFERENCES INTERNAL ARE PATCHED BY                                 
00813200     %   FORWARD REFERENCER.                                                        
00813300     ENTERID(LCP);                                                                  
00813400     IDTYPE(LCP):=LSP;                                                              
00813500     IF (SYMBOL = SEMICOLON) THEN BEGIN                                             
00813600       INSYMBOL;                                                                    
00813700       CHECKIN((FSYS OR IDENTSET),2323);                                            
00813800     END ELSE BEGIN                                                                 
00813900       ERROR(2322);                                                                 
00814000     END;                                                                           
00814100   END; % OF WHILE (SYMBOL=IDENT)                                                   
00814200   ENTERFWDREFS(FWPTR);                                                             
00814300   IF (FWPTR NEQ NIL) THEN FORWARDREFERROR(FWPTR);                                  
00814400 END; % OF TYPE DECLARATION                                                         
00814500                                                                                    
00814600                                                                                    
00814700 PROCEDURE VARDECLARATION;                                                          
00814800 %         **************                                                           
00814900 BEGIN                                                                              
00815000   TYPEIDENTPTR LCP,NXT,LCP1,LCP2;                                                  
00815100   TYPESTRUCTPTR LSP;                                                               
00815200   INTEGER LSIZE,LBITS,I,SIZEFPB,LENGTHOFNAME;                                      
00815300   %                                                                                
00815400   LCP1:=NXT:=NIL;                                                                  
00815500   DO BEGIN                                                                         
00815600     DO BEGIN                                                                       
00815700       IF (SYMBOL = IDENT) THEN BEGIN                                               
00815800         NEWIDENTRECORDWITHNAME(LCP);                                               
00815900         NEXT(LCP):=NIL; KLASS(LCP):=VARS;                                          
00816000         IDTYPE(LCP):=NIL; VKIND(LCP):=ACTUAL;                                      
00816100         VLEV(LCP):=LEXLEVEL;                                                       
00816200         VFORCONTRL(LCP):=REAL(FALSE);                                              
00816300         ENTERID(LCP);                                                              
00816400         IF(NXT=NIL) THEN BEGIN                                                     
00816500           NXT:=LCP;                                                                
00816600         END ELSE BEGIN                                                             
00816700           NEXT(LCP1):=LCP;                                                         
00816800         END;                                                                       
00816900         LCP1:=LCP;                                                                 
00817000         INSYMBOL;                                                                  
00817100       END ELSE BEGIN                                                               
00817200         ERROR(2330);                                                               
00817300       END;                                                                         
00817400       IF NOT SYMBOLIN(FSYS OR COMMACOLONSET OR TYPEDELS) THEN BEGIN                
00817500         ERROR(2331);                                                               
00817600         SKIP(FSYS OR COMMACOLONSEMICOLONSET OR TYPEDELS);                          
00817700       END;                                                                         
00817800       TEST:=(SYMBOL NEQ COMMA);                                                    
00817900       IF NOT TEST THEN INSYMBOL;                                                   
00818000     END UNTIL TEST;                                                                
00818100     IF SYMBOLIN(COLONSET) THEN INSYMBOL ELSE ERROR(2332);                          
00818200     TYP((FSYS OR SEMICOLONSET OR TYPEDELS),LSP,LSIZE,LBITS);                       
00818300     WHILE (NXT NEQ NIL) DO BEGIN                                                   
00818400       IDTYPE(NXT):=LSP; VADDR(NXT):=LC;                                            
00818500       IF (FORM(LSP) <= POWER) THEN BEGIN                                           
00818600         IF LONGSET(LSP) THEN BEGIN                                                 
00818700           GENERATEARRAYDESCRIPTOR(SWORDS(LSP),NXT);                                
00818800         END ELSE BEGIN                                                             
00818900           GENERATEONEWORD(NXT);                                                    
00819000         END;                                                                       
00819100       END ELSE IF (FORM(LSP) = FILES) THEN BEGIN                                   
00819200         IF (FILTYPE(LSP)=CHARPTR) THEN BEGIN                                       
00819300           IDTYPE(NXT):=TEXTPTR;                                                    
00819400         END ELSE BEGIN                                                             
00819500           IF(FILTYPE(LSP)=INTPTR) OR (FILTYPE(LSP)=REALPTR)                        
00819600             OR (FILTYPE(LSP)=BOOLPTR) THEN BEGIN                                   
00819700             ORIGFILTYPE(LSP):=FILTYPE(LSP);                                        
00819800             FILTYPE(LSP):=WORDBUFPTR;                                              
00819900           END;                                                                     
00820000         END;                                                                       
00820100         BEGINNEWSEGMENT(INFOSEGTYPE);                                              
00820200         GENWORD(4"010000000000");                                                  
00820300         LENGTHOFNAME := HEAP[NAME(NXT)].[47:8]-1;                                  
00820400         GENSYL(LENGTHOFNAME+4);                                                    
00820500         GENSYL(1);  GENSYL(1);  GENSYL(LENGTHOFNAME);                              
00820600         FOR I := 1 STEP 1 UNTIL LENGTHOFNAME DO                                    
00820700           GENSYL(REAL(POINTER(HEAP[NAME(NXT)])+I,1));                              
00820800         WHILE (SEGSYLINDEX NEQ 0) DO GENSYL(0);                                    
00820900         IF (LSP=TEXTPTR) THEN BEGIN   %DEFAULTS FOR TEXT                           
00821000           GENWORD(4"031D04030801");   %INTMODE=EBCDIC,KIND=DISK                    
00821100           GENWORD(4"030D07000000");   %FILETYPE=7                                  
00821200         END ELSE BEGIN                                                             
00821300           FOR I := 0 STEP 1 UNTIL (SWORDS(LSP)-1) DO                               
00821400             GENWORD(HEAP[LSP+2+I]);                                                
00821500         END;                                                                       
00821600         CLOSESEGMENT;                                                              
00821700         SIZEFPB:=1+((LENGTHOFNAME+3)DIV CHARSPERWORD+1)+                           
00821800           (IF(LSP=TEXTPTR) THEN 2 ELSE SWORDS(LSP));                               
00821900         GENERATEFPBDESCRIPTOR(SIZEFPB,STARTSEG,NXT);                               
00822000         NEWTEMPARR(LCP2);                                                          
00822100         VLEV(LCP2):=LEXLEVEL;  VADDR(LCP2):=LC+1;                                  
00822200         GENERATESZDESCRIPTOR(SWORDS(FILTYPE(IDTYPE(NXT))),                         
00822300                    (IF(AELTYPE(FILTYPE(IDTYPE(NXT)))=CHARPTR) THEN 4               
00822400                      ELSE 0),LCP2);                                                
00822500         NEWTEMPARR(LCP2);                                                          
00822600         VLEV(LCP2):=LEXLEVEL;  VADDR(LCP2):=LC+2;                                  
00822700         GENERATEARRAYDESCRIPTOR(FILEDATASIZE,LCP2);                                
00822800         LC := LC + 2;   %INC DISPLACEMENT FOR FILE BUFFER & DATA BLOCK             
00822900       END ELSE BEGIN                                                               
00823000         IF(PACKED(LSP)=PACKEDSTRUC) THEN BEGIN                                     
00823100           IF(LBITS=BITSPERWORD) THEN BEGIN                                         
00823200             GENERATEARRAYDESCRIPTOR(LSIZE,NXT);                                    
00823300           END ELSE BEGIN                                                           
00823400             IF(LBITS=1) THEN BEGIN                                                 
00823500               GENERATEARRAYDESCRIPTOR((LSIZE-1) DIV BITSPERWORD+1,NXT);            
00823600             END ELSE BEGIN                                                         
00823700               GENERATESZDESCRIPTOR(LSIZE,(LBITS/2),NXT);                           
00823800             END;                                                                   
00823900           END;                                                                     
00824000         END ELSE BEGIN                                                             
00824100           GENERATEARRAYDESCRIPTOR(LSIZE,NXT);                                      
00824200         END;                                                                       
00824300       END;                                                                         
00824400       LC:=LC+1;                                                                    
00824500       NXT:=NEXT(NXT);                                                              
00824600     END; % OF WHILE                                                                
00824700     IF (SYMBOL = SEMICOLON) THEN BEGIN                                             
00824800       INSYMBOL;                                                                    
00824900       CHECKIN((FSYS OR IDENTSET),2335);                                            
00825000     END ELSE BEGIN                                                                 
00825100       ERROR(2334);                                                                 
00825200     END;                                                                           
00825300   END UNTIL (SYMBOL NEQ IDENT) AND NOT SYMBOLIN(TYPEDELS);                         
00825400   ENTERFWDREFS(FWPTR);                                                             
00825500   IF (FWPTR NEQ NIL) THEN FORWARDREFERROR(FWPTR);                                  
00825600 END; % OF VAR DECLARATION                                                          
00825700                                                                                    
00825800                                                                                    
00825900 % END OF DECLARATIONS **************************************************           
00826000 PROCEDURE FORMATDECLARATION;                                                       
00826100 %         *****************                                                        
00826200 BEGIN                                                                              
00826300 TYPEIDENTPTR LCP;                                                                  
00826400 TYPESTRUCTPTR LSP;                                                                 
00826500 DEFINE                                                                             
00826600     SIZEFORMATARRAY = 1024#,                                                       
00826700     SIZEERRORARRAY = 256#;                                                         
00826800 INTEGER LSIZE;                                                                     
00826900 POINTER FORMATPTR,PTR;                                                             
00827000 REAL ARRAY FORMATARRAY [0:SIZEFORMATARRAY-1],                                      
00827100            ERRORARRAY[0:SIZEERRORARRAY-1],                                         
00827200            TEMP[0:SIZEFORMATARRAY-1];                                              
00827300 INTEGER PARENS,NOCHARS,                                                            
00827400         IND,NOERRORS,                                                              
00827500         SAVEINSYK,SAVEINSYSTART,                                                   
00827600         SAVESTART,SCANSYMBOL;                                                      
00827700 REAL  I,J;                                                                         
00827800 HEX ARRAY                                                                          
00827900    HEXTEMP[0:131];                                                                 
00828000 LABEL NEXT,XIT,BYE;                                                                
00828100 %***********************************************************************           
00828200 %  FIELDS USED BY FORMATSCAN                                                       
00828300 %***********************************************************************           
00828400 INTEGER SCANCOUNT,SCANLENGTH,SCANSTARTPOSN;                                        
00828500 POINTER SCANCOL73,SCANSTART,P;                                                     
00828600 TRUTHSET LETTERS                                                                   
00828700   ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz");                        
00828800 DEFINE INITIALIZESCAN =                                                            
00828900   BEGIN                                                                            
00829000     REPLACE CARDBUFF BY CARDBUF FOR 80 ;                                           
00829100     SCANSTART := CARDBUFF[73-INSYK];                                               
00829200     SCANCOUNT := INSYK;                                                            
00829300     SCANCOL73 := CARDBUFF[72];                                                     
00829400   END#,                                                                            
00829500   CH = REAL(SCANSTART,1)#,                                                         
00829600   BUMPIT = BEGIN                                                                   
00829700              SCANSTART := *+1; SCANCOUNT := *-1;                                   
00829800            END#,                                                                   
00829900   MAXSTRING = 256#,                                                                
00830000   TERMINATESCAN =                                                                  
00830100   BEGIN                                                                            
00830200     REPLACE CARDBUF BY CARDBUFF FOR 80 ;                                           
00830300     INSYP := INSYP1+(73-SCANCOUNT);                                                
00830400     INSYK := SCANCOUNT;                                                            
00830500     SYMBOL := SCANSYMBOL;                                                          
00830600   END#;                                                                            
00830700                                                                                    
00830800 EBCDIC ARRAY                                                                       
00830900     CARDBUFF[0:79],                                                                
00831000     NAMEBUFF[0:MAXSTRING-1];                                                       
00831100 ARRAY                                                                              
00831200     CARDBUFFW[0]=CARDBUFF[*];                                                      
00831300 %***********************************************************************           
00831400 %  FORMATSCAN USED INSTEAD OF INSYMBOL FOR SCANNING FORMATS                        
00831500 %***********************************************************************           
00831600 PROCEDURE FORMATSCAN;                                                              
00831700 %         **********                                                               
00831800 BEGIN                                                                              
00831900 LABEL RESCAN,LOOP,AWAY;                                                            
00832000   DEFINE READNEXTCARD =                                                            
00832100   BEGIN                                                                            
00832200     IF READNEXTLINE(CARDBUFFW) THEN ERROR(4500);                                   
00832300     IF LINEINFOTOG THEN LINEINFO(SCANCOL73);                                       
00832400     REPLACE SCANCOL73 BY " ";                                                      
00832500     SCANSTART := CARDBUFF[0]; SCANCOUNT := 73;                                     
00832600   END#;                                                                            
00832700                                                                                    
00832800 RESCAN:                                                                            
00832900   SCAN SCANSTART:SCANSTART FOR SCANCOUNT:SCANCOUNT UNTIL NEQ " ";                  
00833000   IF (SCANCOUNT=0) THEN BEGIN                                                      
00833100     READNEXTCARD;                                                                  
00833200     GO TO RESCAN;                                                                  
00833300   END;                                                                             
00833400   SCANSTARTPOSN := SCANCOUNT;                                                      
00833500   CASE CH OF BEGIN                                                                 
00833600   "%": BEGIN                                                                       
00833700          SCANSTART := SCANCOL73; SCANCOUNT := 1;                                   
00833800          GO TO RESCAN;                                                             
00833900        END;                                                                        
00834000                                                                                    
00834100   "0":"1":"2":"3":"4":"5":"6":"7":"8":"9":                                         
00834200      BEGIN                                                                         
00834300        REPLACE NAMEBUFF BY SCANSTART:SCANSTART FOR                                 
00834400          SCANCOUNT:SCANCOUNT UNTIL IN NONDIGITS;                                   
00834500        SCANLENGTH := SCANSTARTPOSN - SCANCOUNT;                                    
00834600        SCANSYMBOL := INTCONST;                                                     
00834700        IF (CH="." ) THEN BEGIN                                                     
00834800          BUMPIT;                                                                   
00834900          REPLACE NAMEBUFF[SCANLENGTH] BY ".",                                      
00835000            SCANSTART:SCANSTART FOR SCANCOUNT:SCANCOUNT UNTIL                       
00835100            IN NONDIGITS;                                                           
00835200          SCANSYMBOL := REALCONST;                                                  
00835300          SCANLENGTH := SCANSTARTPOSN - SCANCOUNT;                                  
00835400        END;                                                                        
00835500      END;                                                                          
00835600   ";":                                                                             
00835700        BEGIN                                                                       
00835800          SCANSYMBOL := SEMICOLON; BUMPIT;                                          
00835900        END;                                                                        
00836000                                                                                    
00836100   ")": BEGIN                                                                       
00836200          SCANSYMBOL := RPARENT; BUMPIT;                                            
00836300        END;                                                                        
00836400                                                                                    
00836500   "(": BEGIN                                                                       
00836600          SCANSYMBOL := LPARENT; BUMPIT;                                            
00836700        END;                                                                        
00836800                                                                                    
00836900   "A":"B":"C":"D":"E":"F":"G":"H":"I":"J":"K":"L":"M":                             
00837000   "N":"O":"P":"Q":"R":"S":"T":"U":"V":"W":"X":"Y":"Z":                             
00837100   "a":"b":"c":"d":"e":"f":"g":"h":"i":"j":"k":"l":"m":                             
00837200   "n":"o":"p":"q":"r":"s":"t":"u":"v":"w":"x":"y":"z":                             
00837300        BEGIN                                                                       
00837400          REPLACE NAMEBUFF BY SCANSTART:SCANSTART FOR                               
00837500            SCANCOUNT:SCANCOUNT WHILE IN LETTERS;                                   
00837600          SCANLENGTH := SCANSTARTPOSN - SCANCOUNT;                                  
00837700          SCANSYMBOL := IDENT;                                                      
00837800        END;                                                                        
00837900                                                                                    
00838000   """:"'":                                                                         
00838100        BEGIN                                                                       
00838200          I := CH;  BUMPIT;                                                         
00838300          SCANLENGTH :=0; P := NAMEBUFF;                                            
00838400          IF (CH = I) THEN BEGIN                                                    
00838500            REPLACE P:P BY SCANSTART:SCANSTART FOR 1;                               
00838600            SCANLENGTH := *+1;                                                      
00838700            SCANCOUNT := *-1;                                                       
00838800          END;                                                                      
00838900          SCANSTARTPOSN := SCANCOUNT;                                               
00839000       LOOP:                                                                        
00839100          IF (CH NEQ I) THEN BEGIN                                                  
00839200            IF (SCANCOUNT > 0) THEN BEGIN                                           
00839300              REPLACE P:P BY SCANSTART:SCANSTART FOR 1;                             
00839400              SCANCOUNT:=*-1;                                                       
00839500              SCANLENGTH:=*+1;                                                      
00839600              IF (SCANLENGTH > (MAXSTRING-1)) THEN BEGIN                            
00839700                ERROR(2601);                                                        
00839800                SKIP(SEMICOLONSET);                                                 
00839900                PARENS:=0;      %TERMINATE FORMAT PROC.                             
00840000                GO AWAY;                                                            
00840100              END;                                                                  
00840200            END ELSE BEGIN                                                          
00840300              READNEXTCARD;                                                         
00840400              SCANSTARTPOSN:=73;                                                    
00840500              P:=*-1;                                                               
00840600            END;                                                                    
00840700            GO TO LOOP;                                                             
00840800          END;                                                                      
00840900        AWAY:                                                                       
00841000          BUMPIT;                                                                   
00841100          SCANSYMBOL := STRINGCONST;                                                
00841200       END;                                                                         
00841300   ELSE:                                                                            
00841400       BEGIN                                                                        
00841500          REPLACE NAMEBUFF BY CARDBUFF[73-SCANCOUNT] FOR 1;                         
00841600          SCANSYMBOL := OTHERSY; BUMPIT;   SCANLENGTH := 1;                         
00841700       END;                                                                         
00841800   END;   %OF CASE                                                                  
00841900 END;   %OF FORMATSCAN                                                              
00842000                                                                                    
00842100 %***********************************************************************           
00842200 %  MAIN SECTION OF FORMATDECLARATION                                               
00842300 %***********************************************************************           
00842400 WHILE (SYMBOL = IDENT) DO                                                          
00842500 BEGIN                                                                              
00842600   NEWIDENTRECORDWITHNAME(LCP);                                                     
00842700   IDTYPE(LCP) := NIL;  KLASS(LCP) := FORMATS;                                      
00842800   ENTERID(LCP);                                                                    
00842900   INSYMBOL;                                                                        
00843000   IF(SYMBOL NEQ LPARENT) THEN ERROR(2601);                                         
00843100   SAVESTART := INSYK;                                                              
00843200   INITIALIZESCAN;                                                                  
00843300   FORMATPTR := POINTER(FORMATARRAY);                                               
00843400   REPLACE FORMATPTR BY 4"00" FOR SIZEFORMATARRAY WORDS;                            
00843500   PARENS := NOCHARS := 1;                                                          
00843600   REPLACE FORMATPTR:FORMATPTR BY "(" FOR 1;                                        
00843700   DO BEGIN                                                                         
00843800     FORMATSCAN;                                                                    
00843900     IF (SCANSYMBOL = INTCONST) THEN                                                
00844000     BEGIN                                                                          
00844100       REPLACE FORMATPTR:FORMATPTR BY NAMEBUFF FOR SCANLENGTH;                      
00844200       NOCHARS := *+SCANLENGTH;                                                     
00844300       FORMATSCAN;                                                                  
00844400     END;                                                                           
00844500     CASE SCANSYMBOL OF BEGIN                                                       
00844600     INTCONST:  ERROR(2604);                                                        
00844700     REALCONST:  BEGIN                                                              
00844800          NOCHARS := *+SCANLENGTH;                                                  
00844900          REPLACE FORMATPTR:FORMATPTR BY NAMEBUFF FOR SCANLENGTH;                   
00845000       END;                                                                         
00845100     SEMICOLON:  GO TO XIT;                                                         
00845200     RPARENT:  BEGIN                                                                
00845300          NOCHARS := *+1;                                                           
00845400          REPLACE FORMATPTR:FORMATPTR BY ")" FOR 1;                                 
00845500          PARENS := *-1;                                                            
00845600       END;                                                                         
00845700     LPARENT:  BEGIN                                                                
00845800          NOCHARS := *+1;                                                           
00845900          REPLACE FORMATPTR:FORMATPTR BY "(" FOR 1;                                 
00846000          PARENS := *+1;                                                            
00846100       END;                                                                         
00846200     IDENT:  BEGIN                                                                  
00846300          NOCHARS := *+SCANLENGTH;                                                  
00846400          REPLACE FORMATPTR:FORMATPTR BY NAMEBUFF FOR SCANLENGTH;                   
00846500       END;                                                                         
00846600     STRINGCONST:  BEGIN                                                            
00846700        IF (SCANLENGTH <=256) THEN BEGIN                                            
00846800           NOCHARS := *+SCANLENGTH+2;                                               
00846900           REPLACE FORMATPTR:FORMATPTR BY                                           
00847000             """ FOR 1,                                                             
00847100             NAMEBUFF FOR SCANLENGTH,                                               
00847200             """ FOR 1;                                                             
00847300         END ELSE BEGIN                                                             
00847400            ERROR (2601);                                                           
00847500            GO TO BYE;                                                              
00847600         END;                                                                       
00847700       END;                                                                         
00847800     ELSE:  BEGIN                                                                   
00847900              NOCHARS := NOCHARS+SCANLENGTH;                                        
00848000              REPLACE FORMATPTR:FORMATPTR BY NAMEBUFF FOR SCANLENGTH;               
00848100          END;                                                                      
00848200     END;   % OF CASE SYMBOL                                                        
00848300   END UNTIL (PARENS=0);                                                            
00848400   XIT:                                                                             
00848500   TERMINATESCAN;                                                                   
00848600   REPLACE FORMATPTR:FORMATPTR BY 4"00" FOR 1;                                      
00848700   REPLACE POINTER(ERRORARRAY) BY 4"00" FOR SIZEERRORARRAY WORDS;                   
00848800   IND := FORTALGFORMATENCODER(TEMP,NOCHARS,FORMATARRAY,0,ERRORARRAY,               
00848900           0&1[43:1]);                                                              
00849000                    %NB. OUTPUT NOT EXACTLY THE SAME AS IN ALGOL                    
00849100                    %    BECAUSE ALGOL POOLS FORMAT DESCRIPTORS                     
00849200                    %    PASCAL ISSUES 1 PER FORMAT STATEMENT                       
00849300   IF (NOERRORS := ERRORARRAY[0]>0) THEN                                            
00849400   BEGIN                                                                            
00849500     SAVEINSYK := INSYK; SAVEINSYSTART := INSYSTART;                                
00849600     FOR I := 1 STEP 1 UNTIL NOERRORS DO                                            
00849700     BEGIN                                                                          
00849800       J := ERRORARRAY[I];                                                          
00849900       PTR := POINTER(FORMATARRAY[J.[35:16]])+(J.[39:4]-2);                         
00850000       REPLACE PTR BY 4"06" FOR 1;                                                  
00850100       INSYK := (ABS(SAVESTART-DELTA(FORMATARRAY,PTR)))MOD 72;                      
00850200       INSYSTART := INSYK+1;                                                        
00850300       IF BOOLEAN(J.[47:1]) THEN                                                    
00850400       CASE J.[19:20] OF                                                            
00850500       BEGIN                                                                        
00850600         ERROR(2480);                                                               
00850700         ERROR(2481);                                                               
00850800         ERROR(2482);                                                               
00850900         ERROR(2483);                                                               
00851000         ERROR(2484);                                                               
00851100         ERROR(2485);                                                               
00851200         ERROR(2486);                                                               
00851300         ERROR(2487);                                                               
00851400         ERROR(2488);                                                               
00851500         ERROR(2489);                                                               
00851600         ERROR(2490);                                                               
00851700         ERROR(2491);                                                               
00851800         ERROR(2492);                                                               
00851900         ERROR(2493);                                                               
00852000         ERROR(2494);                                                               
00852100         ERROR(2495);                                                               
00852200         ERROR(2496);                                                               
00852300         ERROR(2497);                                                               
00852400         ERROR(2498);                                                               
00852500         ERROR(2499);                                                               
00852600       END;                                                                         
00852700     END;                                                                           
00852800     INSYK := SAVEINSYK;                                                            
00852900     INSYSTART := SAVEINSYSTART;                                                    
00853000   END;                                                                             
00853100   BEGINNEWSEGMENT(WORDSEGTYPE);                                                    
00853200   I := IND.[46:47];                                                                
00853300   FOR J := 0 STEP 1 UNTIL I DO GENWORD(TEMP[J]);                                   
00853400   VLEV(LCP) := 1;                                                                  
00853500   VADDR(LCP) := SEGNUMBER;                                                         
00853600   CLOSESEGMENT;                                                                    
00853700   IF (SYMBOL NEQ SEMICOLON) THEN                                                   
00853800   BEGIN                                                                            
00853900     INSYMBOL;                                                                      
00854000   END;                                                                             
00854100   IF CODETOG THEN                                                                  
00854200   BEGIN                                                                            
00854300     REPLACE LBUF0 BY "(",                                                          
00854400       VLEV(LCP) FOR 2 DIGITS,                                                      
00854500       ",",                                                                         
00854600       VADDR(LCP) FOR 5 DIGITS,                                                     
00854700       ") = FORMAT DESCRIPTOR";                                                     
00854800     WRITELBUFFER;                                                                  
00854900     PTR := POINTER(TEMP);                                                          
00855000     DO BEGIN                                                                       
00855100       REPLACE HEXTEMP BY PTR:PTR FOR (IF I>11 THEN 11 ELSE I)                      
00855200          WORDS;                                                                    
00855300       REPLACE LBUF0 BY HEXTEMP FOR (IF I>11 THEN 11 ELSE I)*                       
00855400          (CHARSPERWORD*2) WITH HEXTOEBCDIC;                                        
00855500       WRITELBUFFER;                                                                
00855600       I := I-11;                                                                   
00855700     END UNTIL (I<0);                                                               
00855800   END;                                                                             
00855900   IF (SYMBOL = SEMICOLON) THEN                                                     
00856000   BEGIN                                                                            
00856100     INSYMBOL;                                                                      
00856200     CHECKIN(FSYS OR IDENTSET,2602);                                                
00856300   END ELSE BEGIN                                                                   
00856400   BYE:                                                                             
00856500     ERROR(2603);                                                                   
00856600     SKIP(SEMICOLONSET OR BEGINPROCFUNCSET);                                        
00856700   END;                                                                             
00856800 END;  %OF WHILE                                                                    
00856900 END;   %OF FORMARDECLARATION                                                       
00857000 PROCEDURE PROCDECLARATION(FSYMBOL);                                                
00857100 %         ***************                                                          
00857200 VALUE FSYMBOL;                                                                     
00857300 TYPESYMBOL FSYMBOL;                                                                
00857400 BEGIN                                                                              
00857500   TYPESYMBOL LSYMBOL;                                                              
00857600   INTEGER OLDLEV,OLDTOP,PARCNT,OLDLC,LCM,ENTRYPOINT,STATSVEC,LD1SLOT               
00857700     ,LSEG;                                                                         
00857800   TYPEIDENTPTR LIP,LIP1;                                                           
00857900   TYPESTRUCTPTR LSP;                                                               
00858000   TYPESTACKPTR STKPTR;                                                             
00858100   BOOLEAN WASFORWDECLARED;                                                         
00858200   REAL MARKP,SAVEPCW;                                                              
00858300                                                                                    
00858400                                                                                    
00858500 PROCEDURE PARAMETERLIST(FSYS1,FPARNAMES,LC);                                       
00858600 %         *************                                                            
00858700 VALUE FSYS1;                                                                       
00858800 TYPESETOFSYS FSYS1;                                                                
00858900 TYPEIDENTPTR FPARNAMES;                                                            
00859000 INTEGER LC;                                                                        
00859100 BEGIN                                                                              
00859200   INTEGER LC1;                                                                     
00859300   TYPEIDENTPTR LIP,LIP1,LIP2,LIP3,LIP4;                                            
00859400   TYPESTRUCTPTR LSP;                                                               
00859500   TYPEIDKIND LKIND;                                                                
00859600   INTEGER OLDLC,LEN,COUNT,OLDTOP;                                                  
00859700   %                                                                                
00859800   LIP1:=NIL;                                                                       
00859900   IF NOT SYMBOLIN(FSYS1 OR LPARENTSET) THEN BEGIN                                  
00860000     ERROR(2400);                                                                   
00860100     SKIP(FSYS OR FSYS1 OR LPARENTSET);                                             
00860200   END;                                                                             
00860300   IF (SYMBOL = LPARENT) THEN BEGIN                                                 
00860400     IF WASFORWDECLARED THEN BEGIN                                                  
00860500       ERROR(2401);                                                                 
00860600       SKIP(RPARENTSET);                                                            
00860700     END ELSE BEGIN                                                                 
00860800       INSYMBOL;                                                                    
00860900       IF NOT SYMBOLIN(IDENTVARPROCFUNCSET) THEN BEGIN                              
00861000         ERROR(2420);                                                               
00861100         SKIP(FSYS OR IDENTRPARENTSET);                                             
00861200       END;                                                                         
00861300     END;                                                                           
00861400     WHILE SYMBOLIN(IDENTVARPROCFUNCSET) DO BEGIN                                   
00861500       IF (SYMBOL = PROCSY) THEN BEGIN                                              
00861600         INSYMBOL;                                                                  
00861700         IF (SYMBOL = IDENT) THEN BEGIN                                             
00861800           NEW(LIP,PROCFUNCSIZE+(LENGTH DIV 6)+1);                                  
00861900           REPLACE POINTER(HEAP[PROCFUNCSIZE+LIP]) BY NAMEBUF0                      
00862000               FOR (LENGTH+1);                                                      
00862100           NAME(LIP):=PROCFUNCSIZE+LIP;                                             
00862200           IDTYPE(LIP):=NIL; NEXT(LIP):=LIP1;                                       
00862300           PFLEV(LIP):=LEXLEVEL; PFDPLMT(LIP):=LC;                                  
00862400           KLASS(LIP):=PROC;                                                        
00862500           PFDECLKIND(LIP):=DECLARED;                                               
00862600           PFKIND(LIP):=FORMAL;                                                     
00862700           ENTERID(LIP);                                                            
00862800           LIP1:=LIP;                                                               
00862900           LC:=LC+PTRSIZE;                                                          
00863000           INSYMBOL;                                                                
00863100           OLDTOP:=TOP;                                                             
00863200           IF (TOP<MAXTOP) THEN BEGIN                                               
00863300             TOP:=TOP+DISPLAYSIZE;                                                  
00863400             FNAME(TOP):=NIL; OCCUR(TOP):=BLCK; FLABEL(TOP):=NIL;                   
00863500           END ELSE BEGIN                                                           
00863600             ERROR(4458);                                                           
00863700           END;                                                                     
00863800           LC1:=LC;                                                                 
00863900           PARAMETERLIST(FSYS1 OR RPARENTSET,LIP4,LC1);                             
00864000           FPARAMLIST(LIP):=LIP4;                                                   
00864100           TOP:=OLDTOP;                                                             
00864200         END ELSE BEGIN                                                             
00864300           ERROR(2403);                                                             
00864400         END;                                                                       
00864500         CHECKIN((FSYS OR SEMICOLONRPARENTSET),2404);                               
00864600 % FUNCTION                                                                         
00864700       END ELSE IF (SYMBOL = FUNCSY) THEN BEGIN                                     
00864800         INSYMBOL;                                                                  
00864900         IF (SYMBOL = IDENT) THEN BEGIN                                             
00865000           NEW(LIP,PROCFUNCSIZE+(LENGTH DIV 6)+1);                                  
00865100           REPLACE POINTER(HEAP[LIP+PROCFUNCSIZE]) BY NAMEBUF0                      
00865200               FOR (LENGTH+1);                                                      
00865300           NAME(LIP):=LIP+PROCFUNCSIZE;                                             
00865400           IDTYPE(LIP):=NIL; NEXT(LIP):=LIP1;                                       
00865500           PFLEV(LIP):=LEXLEVEL; PFDPLMT(LIP):=LC;                                  
00865600           KLASS(LIP):=FUNC;                                                        
00865700           PFDECLKIND(LIP):=DECLARED;                                               
00865800           PFKIND(LIP):=FORMAL;                                                     
00865900           ENTERID(LIP);                                                            
00866000           LIP1:=LIP;                                                               
00866100           LC:=LC+PTRSIZE;                                                          
00866200           OLDTOP:=TOP;                                                             
00866300           IF (TOP<MAXTOP) THEN BEGIN                                               
00866400             TOP:=TOP+DISPLAYSIZE;                                                  
00866500             FLABEL(TOP):=NIL; OCCUR(TOP):=BLCK; FNAME(TOP):=NIL;                   
00866600           END ELSE BEGIN                                                           
00866700             ERROR(4453);                                                           
00866800           END;                                                                     
00866900           INSYMBOL;                                                                
00867000           LC1:=LC;                                                                 
00867100           PARAMETERLIST(FSYS1 OR COLONSET,LIP4,LC1);                               
00867200           FPARAMLIST(LIP):=LIP4;                                                   
00867300           TOP:=OLDTOP;                                                             
00867400         END;                                                                       
00867500         IF NOT SYMBOLIN(FSYS OR COLONSET) THEN BEGIN                               
00867600           ERROR(2406);                                                             
00867700           SKIP(FSYS OR SEMICOLONRPARENTSET);                                       
00867800         END;                                                                       
00867900         IF (SYMBOL = COLON) THEN BEGIN                                             
00868000           INSYMBOL;                                                                
00868100           IF (SYMBOL = IDENT) THEN BEGIN                                           
00868200             SEARCHID(TYPESET,LIP);                                                 
00868300             LSP:=IDTYPE(LIP);                                                      
00868400             IF (LSP NEQ NIL) THEN BEGIN                                            
00868500               IF NOT INTEST((FORM(LSP)),SCALSUBPTRSET) THEN BEGIN                  
00868600                 ERROR(2407);                                                       
00868700                 LSP:=NIL;                                                          
00868800               END;                                                                 
00868900             END;                                                                   
00869000             IDTYPE(LIP1):=LSP;                                                     
00869100             INSYMBOL;                                                              
00869200           END ELSE BEGIN                                                           
00869300             ERROR(2408);                                                           
00869400           END;                                                                     
00869500           CHECKIN((FSYS OR SEMICOLONRPARENTSET),2409);                             
00869600         END ELSE BEGIN                                                             
00869700           ERROR(2410);                                                             
00869800         END;                                                                       
00869900 % VAR                                                                              
00870000       END ELSE BEGIN                                                               
00870100         IF (SYMBOL = VARSY) THEN BEGIN                                             
00870200           LKIND:=FORMAL; INSYMBOL;                                                 
00870300         END ELSE BEGIN                                                             
00870400           LKIND:=ACTUAL;                                                           
00870500         END;                                                                       
00870600         LIP2:=NIL; COUNT:=0;                                                       
00870700         DO BEGIN                                                                   
00870800           IF (SYMBOL = IDENT) THEN BEGIN                                           
00870900             NEWIDENTRECORDWITHNAME(LIP);                                           
00871000             IDTYPE(LIP):=NIL; KLASS(LIP):=VARS;                                    
00871100             VKIND(LIP):=LKIND; NEXT(LIP):=LIP2;                                    
00871200             VLEV(LIP):=LEXLEVEL;                                                   
00871300             ENTERID(LIP);                                                          
00871400             LIP2:=LIP; COUNT:=COUNT+1;                                             
00871500             INSYMBOL;                                                              
00871600           END;                                                                     
00871700           IF NOT SYMBOLIN(FSYS OR COMMACOLONSET) THEN BEGIN                        
00871800             ERROR(2411);                                                           
00871900             SKIP(FSYS OR COMMASEMICOLONRPARENTSET);                                
00872000           END;                                                                     
00872100           TEST:=(SYMBOL NEQ COMMA);                                                
00872200           IF NOT TEST THEN INSYMBOL;                                               
00872300         END UNTIL TEST;                                                            
00872400         IF SYMBOLIN(COLONSET) THEN BEGIN                                           
00872500           INSYMBOL;                                                                
00872600           IF (SYMBOL = IDENT) THEN BEGIN                                           
00872700             SEARCHID(TYPESET,LIP);                                                 
00872800             LSP:=IDTYPE(LIP);                                                      
00872900             IF (LSP NEQ NIL) THEN BEGIN                                            
00873000               IF (LKIND=ACTUAL) AND (FORM(LSP)=FILES) THEN BEGIN                   
00873100                 ERROR(2412);                                                       
00873200               END;                                                                 
00873300             END;                                                                   
00873400             LIP3:=LIP2;                                                            
00873500             %PARAMETER SIZE SETTINGS (FORMAL AND ACTUAL)                           
00873600             IF (FORM(LSP) < POWER) OR SHORTSET(LSP) THEN BEGIN                     
00873700               LEN := 1;                                                            
00873800             END ELSE BEGIN                                                         
00873900               IF(FORM(LSP)=FILES) THEN BEGIN                                       
00874000                 LEN:=3;                                                            
00874100               END ELSE BEGIN                                                       
00874200                 LEN:=2;                                                            
00874300               END;                                                                 
00874400             END;                                                                   
00874500             LC:=LC+(COUNT*LEN);                                                    
00874600             OLDLC:=LC;                                                             
00874700             % PUT ADDRESSES IN                                                     
00874800             WHILE (LIP2 NEQ NIL) DO BEGIN                                          
00874900               LIP:=LIP2;                                                           
00875000               IDTYPE(LIP2):=LSP; OLDLC:=OLDLC-LEN;                                 
00875100               VADDR(LIP2):=OLDLC;                                                  
00875200               LIP2:=NEXT(LIP2);                                                    
00875300             END;                                                                   
00875400             NEXT(LIP):=LIP1; LIP1:=LIP3;                                           
00875500             INSYMBOL;                                                              
00875600           END ELSE BEGIN                                                           
00875700             ERROR(2415);                                                           
00875800           END;                                                                     
00875900           CHECKIN((FSYS OR SEMICOLONRPARENTSET),2418);                             
00876000         END ELSE BEGIN                                                             
00876100           ERROR(2419);                                                             
00876200         END;                                                                       
00876300       END;                                                                         
00876400       IF (SYMBOL = SEMICOLON) THEN BEGIN                                           
00876500         INSYMBOL;                                                                  
00876600         IF NOT SYMBOLIN(FSYS OR IDENTVARPROCFUNCSET) THEN BEGIN                    
00876700           ERROR(2416);                                                             
00876800           SKIP(FSYS OR IDENTRPARENTSET);                                           
00876900         END;                                                                       
00877000       END;                                                                         
00877100     END; % OF WHILE                                                                
00877200     IF (SYMBOL = RPARENT) THEN BEGIN                                               
00877300       INSYMBOL;                                                                    
00877400       CHECKIN((FSYS OR FSYS1),2417);                                               
00877500     END ELSE BEGIN                                                                 
00877600       ERROR(2417);                                                                 
00877700     END;                                                                           
00877800     LIP3:=NIL;                                                                     
00877900     WHILE (LIP1 NEQ NIL) DO BEGIN                                                  
00878000       LIP2:=NEXT(LIP1); NEXT(LIP1):=LIP3;                                          
00878100       LIP3:=LIP1; LIP1:=LIP2;                                                      
00878200     END;                                                                           
00878300     FPARNAMES:=LIP3;                                                               
00878400   END ELSE BEGIN                                                                   
00878500     FPARNAMES:=NIL;                                                                
00878600   END;                                                                             
00878700 END; % OF PARAMETER LIST                                                           
00878800                                                                                    
00878900                                                                                    
00879000 %         *******************                                                      
00879100 % BODY OF * PROCDECLARATION *                                                      
00879200 %         *******************                                                      
00879300                                                                                    
00879400   OLDLC:=LC; LC:=2;                                                                
00879500   IF (LEXLEVEL = 2) THEN BASELC:=OLDLC;                                            
00879600   IF (SYMBOL = IDENT) THEN BEGIN                                                   
00879700     TRUNCNAME[0]:="      ";   % FILL BLANKS FIRST                                  
00879800     REPLACE POINTER(TRUNCNAME[0]) BY INSYN FOR MIN(LENGTH,6);                      
00879900     % TRUNCNAME[0] NOW HOLDS A SIX-CHAR VERSION OF THE NAME                        
00880000     SEARCHSECTION(FNAME(TOP),LIP);                                                 
00880100     IF (LIP NEQ NIL) THEN BEGIN                                                    
00880200       IF (KLASS(LIP) = PROC) THEN BEGIN                                            
00880300         WASFORWDECLARED:=BOOLEAN(FORWARDDECL(LIP))                                 
00880400           AND (FSYMBOL = PROCSY)                                                   
00880500           AND (PFKIND(LIP) = ACTUAL);                                              
00880600       END ELSE IF (KLASS(LIP) = FUNC) THEN BEGIN                                   
00880700         WASFORWDECLARED:=BOOLEAN(FORWARDDECL(LIP))                                 
00880800           AND (FSYMBOL = FUNCSY)                                                   
00880900           AND (PFKIND(LIP) = ACTUAL);                                              
00881000       END ELSE BEGIN                                                               
00881100         WASFORWDECLARED:=FALSE;                                                    
00881200       END;                                                                         
00881300       IF NOT WASFORWDECLARED THEN ERROR(2450);                                     
00881400     END ELSE BEGIN                                                                 
00881500       WASFORWDECLARED:=FALSE;                                                      
00881600     END;                                                                           
00881700     IF NOT WASFORWDECLARED THEN BEGIN                                              
00881800       NEW(LIP,PROCFUNCSIZE+(LENGTH DIV CHARSPERWORD)+1);                           
00881900       REPLACE POINTER(HEAP[LIP+PROCFUNCSIZE]) BY NAMEBUF0 FOR                      
00882000         (LENGTH+1);                                                                
00882100       NAME(LIP):=LIP+PROCFUNCSIZE;                                                 
00882200       IDTYPE(LIP):=NIL; PFLEV(LIP):=LEXLEVEL;                                      
00882300       PFDECLKIND(LIP):=DECLARED; PFKIND(LIP):=ACTUAL;                              
00882400       PFDPLMT(LIP):=OLDLC;                                                         
00882500       FNCOMPLETE(LIP) := FNCURRENT;                                                
00882600       OLDLC:=OLDLC+1;                                                              
00882700       IF (LEXLEVEL=2) THEN BASELC:=BASELC+1;                                       
00882800       KLASS(LIP):=(IF (FSYMBOL=PROCSY) THEN PROC ELSE FUNC);                       
00882900       BINDIN(LIP):=DONTBIND;                                                       
00883000       ENTERID(LIP);                                                                
00883100     END ELSE BEGIN                                                                 
00883200       LIP1:=NEXT(LIP);                                                             
00883300       FNCOMPLETE(LIP) := FNCURRENT;                                                
00883400       WHILE (LIP1 NEQ NIL) DO BEGIN                                                
00883500         IF (KLASS(LIP1) = VARS) THEN BEGIN                                         
00883600           IF (IDTYPE(LIP1) NEQ NIL) THEN BEGIN                                     
00883700             LCM:=VADDR(LIP1) + (IF (FORM(IDTYPE(LIP1))<POWER OR                    
00883800                                  SHORTSET(IDTYPE(LIP1)))                           
00883900                                 THEN 1 ELSE 2);                                    
00884000             IF (LCM > LC) THEN LC:=LCM;                                            
00884100           END;                                                                     
00884200         END;                                                                       
00884300         LIP1:=NEXT(LIP1);                                                          
00884400       END; % OF WHILE                                                              
00884500     END;                                                                           
00884600     INSYMBOL;                                                                      
00884700   END ELSE BEGIN                                                                   
00884800     ERROR(2451);                                                                   
00884900   END;                                                                             
00885000   OLDLEV:=LEXLEVEL;                                                                
00885100   OLDTOP:=TOP;                                                                     
00885200   IF (LEXLEVEL < MAXLEVEL) THEN BEGIN                                              
00885300     LEXLEVEL:=LEXLEVEL+1;                                                          
00885400   END ELSE BEGIN                                                                   
00885500     ERROR(4452);                                                                   
00885600   END;                                                                             
00885700   IF (TOP < MAXTOP) THEN BEGIN                                                     
00885800     TOP:=TOP+DISPLAYSIZE;                                                          
00885900     FNAME(TOP):=(IF WASFORWDECLARED THEN NEXT(LIP) ELSE NIL);                      
00886000     FLABEL(TOP):=NIL; OCCUR(TOP):=BLCK;                                            
00886100   END ELSE BEGIN                                                                   
00886200     ERROR(4453);                                                                   
00886300   END;                                                                             
00886400   IF (FSYMBOL = PROCSY) THEN BEGIN                                                 
00886500     PARAMETERLIST(SEMICOLONSET,LIP1,LC);                                           
00886600     IF NOT WASFORWDECLARED THEN NEXT(LIP):=LIP1;                                   
00886700   END ELSE BEGIN                                                                   
00886800     PARAMETERLIST(COLONSEMICOLONSET,LIP1,LC);                                      
00886900     IF NOT WASFORWDECLARED THEN NEXT(LIP):=LIP1;                                   
00887000     IF (SYMBOL = COLON) THEN BEGIN                                                 
00887100       INSYMBOL;                                                                    
00887200       IF (SYMBOL = IDENT) THEN BEGIN                                               
00887300         IF WASFORWDECLARED THEN ERROR(2454);                                       
00887400         SEARCHID(TYPESET,LIP1);                                                    
00887500         LSP:=IDTYPE(LIP1); IDTYPE(LIP):=LSP;                                       
00887600         IF (LSP NEQ NIL) THEN BEGIN                                                
00887700           IF NOT INTEST(FORM(LSP),SCALSUBPTRSET) THEN BEGIN                        
00887800             ERROR(2455); IDTYPE(LIP):=NIL;                                         
00887900           END;                                                                     
00888000         END;                                                                       
00888100         INSYMBOL;                                                                  
00888200       END ELSE BEGIN                                                               
00888300         ERROR(2456); SKIP(FSYS OR SEMICOLONSET);                                   
00888400       END;                                                                         
00888500     END ELSE BEGIN                                                                 
00888600       IF NOT WASFORWDECLARED THEN ERROR(2457);                                     
00888700     END;                                                                           
00888800   END;                                                                             
00888900   IF (SYMBOL = SEMICOLON) THEN INSYMBOL ELSE ERROR(2458);                          
00889000   IF (SYMBOL = FORWARDSY) THEN BEGIN                                               
00889100     IF (OP=EXTERNOP) THEN BEGIN                                                    
00889200       IF STANDARDTOG THEN ERROR(1403);                                             
00889300       BITPICKER:=0;                                                                
00889400       MPCWP(LIP):=0;                                                               
00889500       BINDIN(LIP):=BINDITIN;                                                       
00889600       LD1SLOT:=MAKED1SLOT;                                                         
00889700       MPCWP(LIP).CODEPAGE:=LD1SLOT;                                                
00889800       SAVEPCW := MPCWP(LIP) & 1[46:1];                                             
00889900       IF BINDINFOTOG THEN BEGIN                                                    
00890000         BUILDPROCEDUREDIRECTORY(LIP);                                              
00890100       END ELSE BEGIN                                                               
00890200         ERROR(2402);                                                               
00890300       END;                                                                         
00890400       BUILDITEMDESC(LIP,0&1[IDBUILD:1]&1[ADRBUILD:1]);                             
00890500       WRITESEGMENT(DIRECTORY,0,BINDEX,LSEG);                                       
00890600       D1STACKTAGS[LD1SLOT]:=13;                                                    
00890700       D1STACK[LD1SLOT]:=LSEG & 1[43:1] & 1[18:1] & BINDEX [39:20];                 
00890800       BINDEX :=0;                                                                  
00890900       IF CODETOG THEN BEGIN                                                        
00891000         REPLACE LBUF0 BY                                                           
00891100           "(01,",                                                                  
00891200           LD1SLOT FOR 5 DIGITS,                                                    
00891300           ") = EXTERNAL PROCEDURE";                                                
00891400         WRITELBUFFER;                                                              
00891500       END;                                                                         
00891600     END ELSE BEGIN                                                                 
00891700       IF WASFORWDECLARED THEN BEGIN                                                
00891800         ERROR(2459);                                                               
00891900       END ELSE BEGIN                                                               
00892000         FORWARDDECL(LIP):=REAL(TRUE);                                              
00892100         FNCOMPLETE(LIP) := FNFINISHED;                                             
00892200         NEW(STKPTR,DESCPCWSIZE);                                                   
00892300         BUILDKIND(STKPTR):=PCWWORD;                                                
00892400         BUILDVAL(STKPTR):=-1;                                                      
00892500         BUILDID(STKPTR):=LIP;                                                      
00892600         LINKINTOSTACK(STKPTR);                                                     
00892700         SBLDGPTR(LIP):=STKPTR;                                                     
00892800       END;                                                                         
00892900     END;                                                                           
00893000     INSYMBOL;                                                                      
00893100     IF (SYMBOL = SEMICOLON) THEN INSYMBOL ELSE ERROR(2460);                        
00893200     CHECKIN(FSYS,2461);                                                            
00893300   END ELSE BEGIN                                                                   
00893400     % CREATE A STATISTICS VECTOR IN D2 STACK                                       
00893500     IF STATISTICSTOG THEN BEGIN                                                    
00893600       STATSMAX := STATSMAX+2;                                                      
00893700       STATSTABLE[STATSMAX] := TRUNCNAME[0];                                        
00893800       STATSTABLE[STATSMAX+1] := STATSVEC := BASELC;                                
00893900       BASELC:=BASELC+1;                                                            
00894000     END;                                                                           
00894100     FORWARDDECL(LIP):=REAL(FALSE);                                                 
00894200     MARK(MARKP); BEGINNEWSEGMENT(CODESEGTYPE);                                     
00894300     DO BEGIN                                                                       
00894400       BLOCK(FSYS,SEMICOLON,LIP,ENTRYPOINT,LC,STATISTICSTOG,STATSVEC);              
00894500       IF (SYMBOL = SEMICOLON) THEN BEGIN                                           
00894600         INSYMBOL;                                                                  
00894700         IF NOT SYMBOLIN(BEGINPROCFUNCSET) THEN BEGIN                               
00894800           ERROR(2462); SKIP(FSYS);                                                 
00894900         END;                                                                       
00895000       END ELSE BEGIN                                                               
00895100         ERROR(2463);                                                               
00895200       END;                                                                         
00895300     END UNTIL SYMBOLIN(BEGINPROCFUNCSET);                                          
00895400     SAVEPCW:=ASKFORPCW(ENTRYPOINT) & 0 [47:1];                                     
00895500     RELEASE(MARKP); CLOSESEGMENT;                                                  
00895600       FNCOMPLETE(LIP) := FNFINISHED;                                               
00895700   END;                                                                             
00895800   LEXLEVEL:=OLDLEV;                                                                
00895900   TOP:=OLDTOP;                                                                     
00896000   LC:=OLDLC;                                                                       
00896100   IF WASFORWDECLARED THEN BEGIN                                                    
00896200     BUILDVAL(SBLDGPTR(LIP)):=SAVEPCW;                                              
00896300   END ELSE BEGIN                                                                   
00896400     IF NOT(BOOLEAN(FORWARDDECL(LIP))) THEN BEGIN                                   
00896500       NEW(STKPTR,DESCPCWSIZE);                                                     
00896600       BUILDKIND(STKPTR):=PCWWORD;                                                  
00896700       BUILDVAL(STKPTR):=SAVEPCW;                                                   
00896800       BUILDID(STKPTR):=LIP;                                                        
00896900       LINKINTOSTACK(STKPTR);                                                       
00897000     END;                                                                           
00897100   END;                                                                             
00897200   % IF WE ARE AT LEVEL 2, MAYBE THERE ARE SOME STATS VECTORS                       
00897300   % TO PUT INTO THE STACK BUILDING CODE?                                           
00897400   IF ANYSTATISTICSFLAG AND (LEXLEVEL = 2) THEN BEGIN                               
00897500     WHILE (STATSMIN < STATSMAX) DO BEGIN                                           
00897600       STATSMIN := STATSMIN+2;                                                      
00897700       IF (STATSTABLE[STATSMIN+1] NEQ LC) THEN BEGIN                                
00897800         ERROR(3000);                                                               
00897900       END;                                                                         
00898000       GENERATESTATSARRAY;                                                          
00898100       LC := LC+1;                                                                  
00898200     END;                                                                           
00898300     IF (LC NEQ BASELC) THEN BEGIN                                                  
00898400         ERROR(3000);                                                               
00898500     END;                                                                           
00898600   END;                                                                             
00898700 END; % OF PROCEDURE DECLARATION                                                    
00898800                                                                                    
00898900                                                                                    
00899000                                                                                    
00899100                                                                                    
00899200 PROCEDURE BODY(FSYS,ENTRYPOINT);                                                   
00899300 %         ****                                                                     
00899400 VALUE FSYS;                                                                        
00899500 TYPESETOFSYS FSYS;                                                                 
00899600 INTEGER ENTRYPOINT;                                                                
00899700 BEGIN                                                                              
00899800   TYPEIDENTPTR LCP,NXT;                                                            
00899900   INTEGER BODYPLACE,LCT,LASTKIND,FSIZE,RESUME,STATSRUN,I,BCHARSIZE,LAB;            
00900000   REAL TAGSIXWORD;                                                                 
00900100   TYPELBP LLP;                                                                     
00900200   TYPESTACKPTR STACKBUILDPTR;                                                      
00900300   TYPESTRUCTPTR LSP;                                                               
00900400 DEFINE                                                                             
00900500   MAXFILES = 20#;                                                                  
00900600 INTEGER                                                                            
00900700   TAGINDX;                                                                         
00900800 REAL ARRAY                                                                         
00900900   TAG4WORDS[0:(MAXFILES-1)];                                                       
00901000                                                                                    
00901100 PROCEDURE TRAVERSETREE(LIP);                                                       
00901200 %         ============                                                             
00901300 VALUE LIP;                                                                         
00901400 TYPEIDENTPTR LIP;                                                                  
00901500 BEGIN                                                                              
00901600 INTEGER LAB;                                                                       
00901700   IF (LLINK(LIP) NEQ NIL) THEN BEGIN                                               
00901800     TRAVERSETREE(LLINK(LIP));                                                      
00901900   END;                                                                             
00902000   IF(RLINK(LIP) NEQ NIL) THEN BEGIN                                                
00902100     TRAVERSETREE(RLINK(LIP));                                                      
00902200   END;                                                                             
00902300   IF(KLASS(LIP)=VARS) THEN BEGIN                                                   
00902400     IF (FORM(IDTYPE(LIP))=FILES) THEN BEGIN                                        
00902500       IF (VKIND(LIP) NEQ FORMAL) THEN BEGIN                                        
00902600         IF(FILTYPE(IDTYPE(LIP))=CHARBUFPTR) OR (FILTYPE(IDTYPE(LIP))=              
00902700           WORDBUFPTR) THEN BEGIN                                                   
00902800           GENOP(ONE); GENV(VALC,VLEV(LIP),VADDR(LIP)+2);                           
00902900           GENOP2(ISOL,3,4);                                                        
00903000           GENOP1(LT8,3);                                                           
00903100           GENOP(EQUL);                                                             
00903200           LAB:=MAKELABEL;                                                          
00903300           GENBR(BRFL,LAB);                                                         
00903400           IF (FILTYPE(IDTYPE(LIP))=CHARBUFPTR) THEN                                
00903500             GENOP1(LT8,6)                                                          
00903600           ELSE                                                                     
00903700             GENOP1(LT8,3);                                                         
00903800           GENV(VALC,VLEV(LIP),VADDR(LIP)+2);                                       
00903900           GENOP(ZERO);                                                             
00904000           GENOP(EQUL);                                                             
00904100           GENBR(BRTR,LAB);   %NOTHING TO FLUSH                                     
00904200           GENOP(MKST);                                                             
00904300           GENV(NAMC,1,INTRINSICADDR(PASCALTEXTWRITEADDR,                           
00904400                  PASCALINTRINSIC(PASCALTEXTWRITEINTR)));                           
00904500           GENV(NAMC,VLEV(LIP),VADDR(LIP)); GENOP(STFF);                            
00904600           GENV(NAMC,VLEV(LIP),VADDR(LIP)+1); GENOP(LOAD);                          
00904700           GENV(NAMC,VLEV(LIP),VADDR(LIP)+2); GENOP(LOAD);                          
00904800           GENOP(ZERO);                                                             
00904900           GENOP(DUPL); GENOP(DUPL); GENOP(DUPL); GENOP(DUPL);                      
00905000           GENLIT(7 & 1[47:1]);                                                     
00905100           GENOP(ENTR);                                                             
00905200           GENLABEL(LAB);                                                           
00905300         END ELSE BEGIN                                                             
00905400           GENOP(MKST);                                                             
00905500           GENV(NAMC,1,INTRINSICADDR(PASCALFLUSHFILEADDR,                           
00905600                       PASCALINTRINSIC(PASCALFLUSHBUFFERINTR)));                    
00905700           GENV(NAMC,VLEV(LIP),VADDR(LIP)); GENOP(STFF);                            
00905800           GENV(NAMC,VLEV(LIP),VADDR(LIP)+1); GENOP(LOAD);                          
00905900           GENV(NAMC,VLEV(LIP),VADDR(LIP)+2); GENOP(LOAD);                          
00906000           GENOP(ENTR);                                                             
00906100         END;                                                                       
00906200       END;                                                                         
00906300     END;                                                                           
00906400   END;                                                                             
00906500 END;                                                                               
00906600                                                                                    
00906700                                                                                    
00906800 PROCEDURE STATEMENT(FSYS);                                                         
00906900 %         *********                                                                
00907000 VALUE FSYS;                                                                        
00907100 TYPESETOFSYS FSYS;                                                                 
00907200 BEGIN                                                                              
00907300   LABEL FOUNDLABEL;                                                                
00907400   TYPEIDENTPTR IDENTIFIERPTR;                                                      
00907500   TYPELBP LABELRECPTR;                                                             
00907600   TYPEDISPRANGE LLTOP;                                                             
00907700   BOOLEAN READFUNCTION;                                                            
00907800                                                                                    
00907900                                                                                    
00908000 PROCEDURE EXPRESSION(FSYS);                                                        
00908100 %         **********                                                               
00908200 VALUE FSYS;                                                                        
00908300 TYPESETOFSYS FSYS;                                                                 
00908400 FORWARD;                                                                           
00908500                                                                                    
00908600 PROCEDURE RANGECHECK(REQMIN,REQMAX,ACTMIN,ACTMAX);                                 
00908700 %         **********                                                               
00908800 VALUE REQMIN,REQMAX,ACTMIN,ACTMAX;                                                 
00908900 REAL REQMIN,REQMAX,ACTMIN,ACTMAX;                                                  
00909000 %     REQMIN AND REQMAX ARE THE BOUNDS REQUIRED                                    
00909100 %      ACTMIN AND ACTMAX ARE THE ACTUAL BOUNDS                                     
00909200 BEGIN                                                                              
00909300   INTEGER LABOK,LABERR;                                                            
00909400   IF (ACTMIN < REQMIN) OR (ACTMAX > REQMAX) THEN BEGIN                             
00909500     IF (REQMAX < ACTMIN) OR (ACTMAX < REQMIN) THEN BEGIN                           
00909600       ERROR(2250);                                                                 
00909700     END ELSE BEGIN                                                                 
00909800       IF BOUNDSCHECKTOG THEN BEGIN                                                 
00909900         LABERR := -1;                                                              
00910000         IF (ACTMIN < REQMIN) THEN BEGIN    % MIN TEST REQUIRED                     
00910100           GENOP(DUPL);                                                             
00910200           LABOK := MAKELABEL;                                                      
00910300           LABERR := MAKELABEL;                                                     
00910400           GENLIT(REQMIN);                                                          
00910500           GENOP(LESS);                                                             
00910600           GENBR(BRFL,LABOK);                                                       
00910700           GENLABEL(LABERR);                                                        
00910800           RUNTIMEERROR(5);                                                         
00910900           GENLABEL(LABOK);                                                         
00911000         END;                                                                       
00911100         IF (ACTMAX > REQMAX) THEN BEGIN                                            
00911200           GENOP(DUPL);                                                             
00911300           GENLIT(REQMAX);                                                          
00911400           GENOP(GRTR);                                                             
00911500           IF (LABERR = -1) THEN BEGIN    % MIN TEST NOT DONE                       
00911600             LABOK := MAKELABEL;                                                    
00911700             GENBR(BRFL,LABOK);                                                     
00911800             RUNTIMEERROR(BOUNDSERROR);                                             
00911900             GENLABEL(LABOK);                                                       
00912000           END ELSE BEGIN                                                           
00912100             GENBR(BRTR,LABERR);                                                    
00912200           END;                                                                     
00912300         END;                                                                       
00912400       END;                                                                         
00912500     END;                                                                           
00912600   END;                                                                             
00912700 END;   %OF RANGECHECK                                                              
00912800                                                                                    
00912900                                                                                    
00913000 PROCEDURE MAKECHARDESCR(BITSIZE);                                                  
00913100 %         *************                                                            
00913200 VALUE BITSIZE;                                                                     
00913300 INTEGER BITSIZE;                                                                   
00913400 BEGIN                                                                              
00913500 IF (BITSIZE NEQ 1) THEN BEGIN                                                      
00913600   GENOP(LOAD);                                                                     
00913700   GENOP(DUPL);                                                                     
00913800   GENOP2(ISOL,39,20);                                                              
00913900   CASE BITSIZE OF BEGIN                                                            
00914000   4: GENLIT(12);                                                                   
00914100   6: GENLIT(8);                                                                    
00914200   48:                                                                              
00914300   8: GENLIT(6);                                                                    
00914400   END;                                                                             
00914500   GENOP(MULT);                                                                     
00914600   GENOP2(INSR,39,20);                                                              
00914700   CASE BITSIZE OF BEGIN                                                            
00914800   4: GENOP1(BSET,41);                                                              
00914900   6: GENOP1(BSET,41);                                                              
00915000      GENOP1(BSET,40);                                                              
00915100   48:                                                                              
00915200   8: GENOP1(BSET,42);                                                              
00915300   END;                                                                             
00915400 END;                                                                               
00915500 END;   %OF MAKECHARDESCR;                                                          
00915600                                                                                    
00915700 PROCEDURE LOADIRW;                                                                 
00915800 %         *******                                                                  
00915900 BEGIN                                                                              
00916000   LABEL FORCESEGMENTATION;                                                         
00916100                                                                                    
00916200   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
00916300     IF (GKIND = VARBL) THEN BEGIN                                                  
00916400       CASE GACCESS OF BEGIN                                                        
00916500                                                                                    
00916600       DRCT:                                                                        
00916700         GENV(NAMC,GVLEVEL,GDPLMT); GENOP(STFF);                                    
00916800                                                                                    
00916900       INDRCT:                                                                      
00917000       INXD:                                                                        
00917100         IF (GACCESS = INXD) THEN BEGIN                                             
00917200           IF (GIDPLMT NEQ 0) THEN BEGIN                                            
00917300             IF (GIDPLMT > 0) THEN BEGIN                                            
00917400               GENLIT(GIDPLMT); GENOP(ADD);                                         
00917500             END ELSE BEGIN                                                         
00917600               GENLIT(-GIDPLMT); GENOP(SUBT);                                       
00917700             END;                                                                   
00917800           END;                                                                     
00917900           IF (GCHARSIZE=1) THEN BEGIN                                              
00918000             GENOP(DUPL);                                                           
00918100             GENLIT(BITSPERWORD);                                                   
00918200             GENOP(RDIV);                                                           
00918300             GENOP(EXCH);                                                           
00918400             GENLIT(BITSPERWORD);                                                   
00918500             GENOP(IDIV);                                                           
00918600           END;                                                                     
00918700         END ELSE BEGIN                                                             
00918800           GENLIT(GIDPLMT);                                                         
00918900         END;                                                                       
00919000         IF (FORM(GTYPTR) < POWER) OR SHORTSET(GTYPTR) THEN BEGIN                   
00919100           GENV(NAMC,GVLEVEL,GDPLMT); GENOP(INDX);                                  
00919200         END ELSE BEGIN                                                             
00919300           GENV(NAMC,GVLEVEL,GDPLMT);                                               
00919400           IF GCHARDESCR THEN BEGIN                                                 
00919500             MAKECHARDESCR(GCHARSIZE);                                              
00919600           END ELSE BEGIN                                                           
00919700             GENOP(LOAD);                                                           
00919800           END;                                                                     
00919900         END;                                                                       
00920000                                                                                    
00920100       ELSE:                                                                        
00920200         ERROR(3720);                                                               
00920300                                                                                    
00920400       END; % OF CASE                                                               
00920500     END;                                                                           
00920600   END;                                                                             
00920700 END; % OF LOAD IRW                                                                 
00920800                                                                                    
00920900 PROCEDURE LOADV;                                                                   
00921000 %         *****                                                                    
00921100 BEGIN                                                                              
00921200   DEFINE ADJUSTSUBRANGEVALUE = BEGIN                                               
00921300     IF(FORM(GTYPTR)=SUBRANGE) THEN BEGIN                                           
00921400       IF(SMIN(GTYPTR)>0) THEN BEGIN                                                
00921500         GENLIT(SMIN(GTYPTR));  GENOP(ADD);                                         
00921600       END ELSE BEGIN                                                               
00921700         IF(SMIN(GTYPTR)<0) THEN BEGIN                                              
00921800           GENLIT(ABS(SMIN(GTYPTR))); GENOP(SUBT);                                  
00921900         END;                                                                       
00922000       END;                                                                         
00922100     END;                                                                           
00922200     GPACKEDARRAY:=GPACKEDSUBRFIELD:=FALSE;                                         
00922300   END#;                                                                            
00922400   LABEL FORCESEGMENTATION;                                                         
00922500   %                                                                                
00922600   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
00922700     CASE GKIND OF BEGIN                                                            
00922800                                                                                    
00922900     CST:                                                                           
00923000       IF (FORM(GTYPTR) = SCALAR) THEN BEGIN                                        
00923100         GENLIT(GCVAL);                                                             
00923200       END ELSE IF (GTYPTR = NILPTR) THEN BEGIN                                     
00923300         GENOP1(LT8,4"1F");  GENOP2(ISOL,9,48);                                     
00923400       END ELSE IF SHORTSET(GTYPTR) THEN BEGIN                                      
00923500         GENLIT(GCVAL);                                                             
00923600       END ELSE BEGIN                                                               
00923700         ERROR(2722);                                                               
00923800       END;                                                                         
00923900                                                                                    
00924000     VARBL:                                                                         
00924100       CASE GACCESS OF BEGIN                                                        
00924200         %                                                                          
00924300       DRCT:                                                                        
00924400         GENV(VALC,GVLEVEL,GDPLMT);                                                 
00924500       INDRCT:                                                                      
00924600         IF GPACKEDSUBRFIELD THEN BEGIN                                             
00924700           GENLIT(GIDPLMT);                                                         
00924800           GENV(VALC,GVLEVEL,GDPLMT);                                               
00924900         END ELSE BEGIN                                                             
00925000           CASE GCHARSIZE OF BEGIN                                                  
00925100           1: GENLIT(GIDPLMT);                                                      
00925200             GENV(VALC,GVLEVEL,GDPLMT);                                             
00925300             GENOP2(ISOL,GBITADDR,GCHARSIZE);                                       
00925400           48: GENLIT(GIDPLMT);                                                     
00925500             GENV(VALC,GVLEVEL,GDPLMT);                                             
00925600           4:6:8: GENLIT(GIDPLMT);                                                  
00925700             GENV(NAMC,GVLEVEL,GDPLMT);                                             
00925800             IF GCHARDESCR THEN MAKECHARDESCR(GCHARSIZE);                           
00925900             GENOP(INDX);                                                           
00926000             GENOP(ONE);                                                            
00926100             GENOP(SISO);                                                           
00926200           END;                                                                     
00926300         END;                                                                       
00926400         IF GPACKEDSUBRFIELD THEN BEGIN                                             
00926500           GENOP2(ISOL,GBITADDR,GBITRANGE);                                         
00926600           ADJUSTSUBRANGEVALUE;                                                     
00926700         END ELSE BEGIN                                                             
00926800           IF GPACKEDARRAY THEN BEGIN                                               
00926900             ADJUSTSUBRANGEVALUE;                                                   
00927000           END;                                                                     
00927100         END;                                                                       
00927200       INXD:                                                                        
00927300         IF (GIDPLMT NEQ 0) THEN BEGIN                                              
00927400           IF (GIDPLMT > 0) THEN BEGIN                                              
00927500             GENLIT(GIDPLMT); GENOP(ADD);                                           
00927600           END ELSE BEGIN                                                           
00927700             GENLIT(-GIDPLMT); GENOP(SUBT);                                         
00927800           END;                                                                     
00927900           GIDPLMT:=0;                                                              
00928000         END;                                                                       
00928100         IF(GPACKEDARRAY) THEN BEGIN                                                
00928200           CASE GCHARSIZE OF BEGIN                                                  
00928300           1: GENOP(DUPL);                                                          
00928400             GENOP1(LT8,BITSPERWORD);                                               
00928500             GENOP(RDIV);                                                           
00928600             GENOP(EXCH);                                                           
00928700             GENLIT(BITSPERWORD);                                                   
00928800             GENOP(IDIV);                                                           
00928900             GENV(VALC,GVLEVEL,GDPLMT);                                             
00929000           4:6:8: GENV(NAMC,GVLEVEL,GDPLMT);                                        
00929100             IF GCHARDESCR THEN MAKECHARDESCR(GCHARSIZE);                           
00929200             GENOP(INDX);                                                           
00929300             GENOP(ONE);                                                            
00929400             GENOP(SISO);                                                           
00929500           48: GENV(VALC,GVLEVEL,GDPLMT);                                           
00929600           END;                                                                     
00929700         END ELSE BEGIN                                                             
00929800           GENV(VALC,GVLEVEL,GDPLMT);                                               
00929900         END;                                                                       
00930000         IF (GPACKEDARRAY) THEN BEGIN                                               
00930100           IF (GCHARSIZE = 1) THEN BEGIN                                            
00930200             GENLIT(BITSPERWORD-1);                                                 
00930300             GENOP(RSUP);                                                           
00930400             GENOP(SUBT);                                                           
00930500             GENOP(ONE);                                                            
00930600             GENOP(DISO);                                                           
00930700           END;                                                                     
00930800           ADJUSTSUBRANGEVALUE;                                                     
00930900         END ELSE BEGIN                                                             
00931000           IF GPACKEDSUBRFIELD THEN BEGIN                                           
00931100             GENOP2(ISOL,GBITADDR,GBITRANGE);                                       
00931200             ADJUSTSUBRANGEVALUE;                                                   
00931300           END;                                                                     
00931400         END;                                                                       
00931500       END; % OF CASE                                                               
00931600                                                                                    
00931700     EXPR:                                                                          
00931800       ; % NOT ERROR , BUT OK DO NOTHING                                            
00931900     END; % OF CASE GKIND                                                           
00932000     GKIND:=EXPR;                                                                   
00932100   END;                                                                             
00932200 END; % OF LOADV                                                                    
00932300                                                                                    
00932400                                                                                    
00932500 PROCEDURE STORE(                                                                   
00932600 %         *****                                                                    
00932700         LTYPTR,LACCESS,LVLEVEL,LDPLMT,LIDPLMT,LCHARSIZE,LPACKEDSUBRFIELD           
00932800            ,LPACKEDARRAY,LBITADDR,LBITRANGE,LCHARDESCR,OPCODE                      
00932900           );                                                                       
00933000 VALUE LTYPTR,LACCESS,LVLEVEL,LDPLMT,LIDPLMT,LCHARSIZE,                             
00933100   LBITADDR,LBITRANGE,LCHARDESCR,OPCODE;                                            
00933200 TYPESTRUCTPTR LTYPTR;                                                              
00933300 TYPEVACCESS LACCESS;                                                               
00933400 BOOLEAN LPACKEDSUBRFIELD,LPACKEDARRAY,LCHARDESCR;                                  
00933500 INTEGER LVLEVEL,LDPLMT,LIDPLMT,LCHARSIZE,LBITADDR,LBITRANGE,OPCODE;                
00933600 BEGIN                                                                              
00933700   DEFINE                                                                           
00933800     ADJUSTSUBRANGEVALUE = BEGIN                                                    
00933900       IF(FORM(LTYPTR)=SUBRANGE) THEN BEGIN                                         
00934000         IF(SMIN(LTYPTR)>0) THEN BEGIN                                              
00934100           GENLIT(SMIN(LTYPTR));  GENOP(SUBT);                                      
00934200         END ELSE BEGIN                                                             
00934300           IF(SMIN(LTYPTR)<0) THEN BEGIN                                            
00934400             GENLIT(ABS(SMIN(LTYPTR)));  GENOP(ADD);                                
00934500           END;                                                                     
00934600         END;                                                                       
00934700       END;                                                                         
00934800       IF (LACCESS NEQ INDRCT) THEN BEGIN                                           
00934900         LPACKEDSUBRFIELD:=LPACKEDARRAY:=FALSE;                                     
00935000       END;                                                                         
00935100     END#;                                                                          
00935200                                                                                    
00935300   IF (LTYPTR NEQ NIL) THEN BEGIN                                                   
00935400     CASE LACCESS OF BEGIN                                                          
00935500                                                                                    
00935600     DRCT:                                                                          
00935700         GENV(NAMC,LVLEVEL,LDPLMT);                                                 
00935800                                                                                    
00935900     INDRCT:                                                                        
00936000         IF LPACKEDARRAY THEN BEGIN                                                 
00936100           ADJUSTSUBRANGEVALUE;                                                     
00936200         END;                                                                       
00936300         GENLIT(LIDPLMT);                                                           
00936400         GENV(NAMC,LVLEVEL,LDPLMT);                                                 
00936500         IF LCHARDESCR THEN MAKECHARDESCR(LCHARSIZE);                               
00936600         GENOP(INDX);                                                               
00936700         IF LPACKEDSUBRFIELD THEN BEGIN                                             
00936800           IF(LBITRANGE NEQ BITSPERWORD) THEN BEGIN                                 
00936900             GENOP(DUPL);                                                           
00937000             GENOP(LOAD);                                                           
00937100             GENOP(RSUP);                                                           
00937200             ADJUSTSUBRANGEVALUE;                                                   
00937300             GENOP2(INSR,LBITADDR,LBITRANGE);                                       
00937400           END;                                                                     
00937500           LPACKEDSUBRFIELD:=LPACKEDARRAY:=FALSE;                                   
00937600         END ELSE BEGIN                                                             
00937700           IF LPACKEDARRAY THEN BEGIN                                               
00937800             IF (LCHARSIZE NEQ BITSPERWORD) THEN BEGIN                              
00937900               IF(LCHARSIZE=1) THEN BEGIN                                           
00938000                 GENOP(DUPL);                                                       
00938100                 GENOP(LOAD);                                                       
00938200                 GENOP(RSUP);                                                       
00938300                 GENOP2(INSR,LBITADDR,BOOLBITSIZE);                                 
00938400               END ELSE BEGIN                                                       
00938500                 GENOP(EXCH);                                                       
00938600                 CASE LCHARSIZE OF BEGIN                                            
00938700                 4: GENOP2(ISOL,3,48);                                              
00938800                 6: GENOP2(ISOL,5,48);                                              
00938900                 8: GENOP2(ISOL,7,48);                                              
00939000                 END;                                                               
00939100                 GENOP(ONE);                                                        
00939200               END;                                                                 
00939300             END;                                                                   
00939400             LPACKEDARRAY:=LPACKEDSUBRFIELD:=FALSE;                                 
00939500           END;                                                                     
00939600         END;                                                                       
00939700                                                                                    
00939800     INXD:                                                                          
00939900         IF LPACKEDSUBRFIELD THEN BEGIN                                             
00940000           ADJUSTSUBRANGEVALUE;                                                     
00940100           IF (LBITRANGE NEQ BITSPERWORD) THEN BEGIN                                
00940200             GENOP(EXCH);                                                           
00940300             GENOP(DUPL);                                                           
00940400             GENOP(LOAD);                                                           
00940500             GENOP(RSUP);                                                           
00940600             GENOP2(INSR,LBITADDR,LBITRANGE);                                       
00940700           END;                                                                     
00940800         END ELSE BEGIN                                                             
00940900           IF LPACKEDARRAY THEN BEGIN                                               
00941000             ADJUSTSUBRANGEVALUE;                                                   
00941100           END;                                                                     
00941200           IF (LCHARSIZE NEQ BITSPERWORD) THEN BEGIN                                
00941300             IF(LCHARSIZE=1) THEN BEGIN                                             
00941400               GENOP(EXCH);                                                         
00941500               GENOP(LOAD);                                                         
00941600               GENOP(RSUP);                                                         
00941700               GENLIT(BITSPERWORD-1);                                               
00941800               GENOP(EXCH);                                                         
00941900               GENOP(SUBT);                                                         
00942000               GENOP(RSUP);                                                         
00942100               GENOP(ONE);                                                          
00942200               GENOP(EXCH);                                                         
00942300               GENOP(DINS);                                                         
00942400             END ELSE BEGIN                                                         
00942500               CASE LCHARSIZE OF BEGIN                                              
00942600               4: GENOP2(ISOL,3,48);                                                
00942700               6: GENOP2(ISOL,5,48);                                                
00942800               8: GENOP2(ISOL,7,48);                                                
00942900               END;                                                                 
00943000               GENOP(ONE);                                                          
00943100             END;                                                                   
00943200           END;                                                                     
00943300         END;                                                                       
00943400                                                                                    
00943500     ELSE:                                                                          
00943600         ERROR(3720);                                                               
00943700                                                                                    
00943800     END;                                                                           
00943900     GENOP(OPCODE);                                                                 
00944000   END;                                                                             
00944100 END; % OF STORE                                                                    
00944200                                                                                    
00944300                                                                                    
00944400 PROCEDURE LOADADDRIFINXD;                                                          
00944500 %         **************                                                           
00944600 BEGIN                                                                              
00944700   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
00944800     IF (GKIND = VARBL) THEN BEGIN                                                  
00944900       IF (GACCESS = INXD) THEN BEGIN                                               
00945000         IF (GIDPLMT NEQ 0) THEN BEGIN                                              
00945100           IF (GIDPLMT > 0) THEN BEGIN                                              
00945200             GENLIT(GIDPLMT); GENOP(ADD);                                           
00945300           END ELSE BEGIN                                                           
00945400             GENLIT(-GIDPLMT); GENOP(SUBT);                                         
00945500           END;                                                                     
00945600         END;                                                                       
00945700         GIDPLMT:=0;                                                                
00945800         IF (GCHARSIZE=1) AND GPACKEDARRAY THEN BEGIN                               
00945900           GENOP(DUPL);                                                             
00946000           GENLIT(BITSPERWORD);                                                     
00946100           GENOP(RDIV);                                                             
00946200           GENOP(EXCH);                                                             
00946300           GENLIT(BITSPERWORD);                                                     
00946400           GENOP(IDIV);                                                             
00946500         END;                                                                       
00946600         GENV(NAMC,GVLEVEL,GDPLMT);                                                 
00946700         IF GCHARDESCR THEN MAKECHARDESCR(GCHARSIZE);                               
00946800         GENOP(INDX);                                                               
00946900         IF(GCHARSIZE = 1) AND GPACKEDARRAY THEN BEGIN                              
00947000           GENOP(DUPL); GENOP(RSDN);                                                
00947100         END;                                                                       
00947200       END;                                                                         
00947300     END;                                                                           
00947400   END;                                                                             
00947500 END; % OF LOAD ADDRESS IF INDEXED                                                  
00947600                                                                                    
00947700                                                                                    
00947800 PROCEDURE LOADADDRESS;                                                             
00947900 %         ***********                                                              
00948000 BEGIN                                                                              
00948100   LABEL FORCESEGMENTATION;                                                         
00948200                                                                                    
00948300   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
00948400     IF (GKIND = VARBL) THEN BEGIN                                                  
00948500       CASE GACCESS OF BEGIN                                                        
00948600                                                                                    
00948700       INDRCT:                                                                      
00948800         GENLIT(GIDPLMT); GIDPLMT:=0;                                               
00948900         GACCESS:=INXD;                                                             
00949000                                                                                    
00949100       INXD:                                                                        
00949200         IF (GIDPLMT NEQ 0) THEN BEGIN                                              
00949300           IF (GIDPLMT > 0) THEN BEGIN                                              
00949400             GENLIT(GIDPLMT); GENOP(ADD);                                           
00949500           END ELSE BEGIN                                                           
00949600             GENLIT(-GIDPLMT); GENOP(SUBT);                                         
00949700           END;                                                                     
00949800           GIDPLMT:=0;                                                              
00949900         END;                                                                       
00950000                                                                                    
00950100       ELSE:                                                                        
00950200         ERROR(3720);                                                               
00950300                                                                                    
00950400       END; % OF CASE GACCESS                                                       
00950500     END ELSE BEGIN                                                                 
00950600       ERROR(2721);                                                                 
00950700     END;                                                                           
00950800   END;                                                                             
00950900 END; % OF LOAD ADDRESS                                                             
00951000                                                                                    
00951100                                                                                    
00951200 PROCEDURE LOADINXDDESCRIPTOR;                                                      
00951300 %         ******************                                                       
00951400 BEGIN                                                                              
00951500   LABEL FORCESEGMENTATION;                                                         
00951600   %                                                                                
00951700   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
00951800     IF (GKIND = CST) THEN BEGIN                                                    
00951900       IF STRING(GTYPTR) THEN BEGIN                                                 
00952000         GKIND:=VARBL; GACCESS:=INDRCT;                                             
00952100       END;                                                                         
00952200     END;                                                                           
00952300     IF (GKIND = VARBL) THEN BEGIN                                                  
00952400       CASE GACCESS OF BEGIN                                                        
00952500                                                                                    
00952600       INDRCT:                                                                      
00952700         GENLIT(GIDPLMT);                                                           
00952800         GENV(NAMC,GVLEVEL,GDPLMT);                                                 
00952900         IF GCHARDESCR THEN MAKECHARDESCR(GCHARSIZE);                               
00953000         GENOP(INDX);                                                               
00953100                                                                                    
00953200       INXD:                                                                        
00953300         IF (GIDPLMT NEQ 0) THEN BEGIN                                              
00953400           IF (GIDPLMT > 0) THEN BEGIN                                              
00953500             GENLIT(GIDPLMT); GENOP(ADD);                                           
00953600           END ELSE BEGIN                                                           
00953700             GENLIT(-GIDPLMT); GENOP(SUBT);                                         
00953800           END;                                                                     
00953900         END;                                                                       
00954000         IF (GCHARSIZE = 1) THEN BEGIN                                              
00954100           GENOP(DUPL);                                                             
00954200           GENLIT(BITSPERWORD);                                                     
00954300           GENOP(RDIV);                                                             
00954400           GENOP(EXCH);                                                             
00954500           GENLIT(BITSPERWORD);                                                     
00954600           GENOP(IDIV);                                                             
00954700         END;                                                                       
00954800         GENV(NAMC,GVLEVEL,GDPLMT);                                                 
00954900         IF GCHARDESCR THEN MAKECHARDESCR(GCHARSIZE);                               
00955000         GENOP(INDX);                                                               
00955100                                                                                    
00955200       ELSE:                                                                        
00955300         ERROR(3720);                                                               
00955400                                                                                    
00955500       END; % OF CASE                                                               
00955600     END;                                                                           
00955700   END;                                                                             
00955800 END; % OF LOAD INDEXED DESCRIPTOR                                                  
00955900                                                                                    
00956000                                                                                    
00956100 PROCEDURE LOADSTRINGDESCRIPTOR;                                                    
00956200 %         ********************                                                     
00956300 BEGIN                                                                              
00956400   LABEL FORCESEGMENTATION;                                                         
00956500   %                                                                                
00956600   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
00956700     LOADINXDDESCRIPTOR;                                                            
00956800     IF (GCHARSIZE=BITSPERWORD) OR (GCHARSIZE=1) THEN BEGIN                         
00956900       IF NOT GCHARDESCR THEN BEGIN                                                 
00957000         GENOP1(BSET,42);                                                           
00957100       END;                                                                         
00957200     END;                                                                           
00957300   END;                                                                             
00957400 END; % OF LOAD STRING DESCRIPTOR                                                   
00957500                                                                                    
00957600                                                                                    
00957700 PROCEDURE SELECTOR(FSYS,FORMALIDENTPTR);                                           
00957800 %         ********                                                                 
00957900 VALUE FSYS,FORMALIDENTPTR;                                                         
00958000 TYPESETOFSYS FSYS;                                                                 
00958100 TYPEIDENTPTR FORMALIDENTPTR;                                                       
00958200 BEGIN                                                                              
00958300   TYPEIDENTPTR IDENTIFIERPTR;                                                      
00958400   DECLARELATTR;                                                                    
00958500   BOOLEAN MULTIDIMARRAY;                                                           
00958600   INTEGER LOWERBOUND,UPPERBOUND,LSIZE,LBITS;                                       
00958700   %                                                                                
00958800   GTYPTR:=IDTYPE(FORMALIDENTPTR); GKIND:=VARBL;                                    
00958900   GCHARDESCR:=FALSE;                                                               
00959000   GPACKEDARRAY:=GPACKEDSUBRFIELD:=FALSE;                                           
00959100   MULTIDIMARRAY := FALSE;                                                          
00959200   CASE KLASS(FORMALIDENTPTR) OF BEGIN                                              
00959300     %                                                                              
00959400   VARS:                                                                            
00959500     GVLEVEL:=VLEV(FORMALIDENTPTR); GDPLMT:=VADDR(FORMALIDENTPTR);                  
00959600     IF (FORM(GTYPTR) = RECORDS) OR (FORM(GTYPTR) = ARRAYS) OR                      
00959700         LONGSET(GTYPTR) THEN BEGIN                                                 
00959800       IF (VKIND(FORMALIDENTPTR) = ACTUAL) THEN BEGIN                               
00959900         GACCESS:=INDRCT; GIDPLMT:=0;                                               
00960000       END ELSE BEGIN                                                               
00960100         GACCESS:=INXD; GIDPLMT:=0;                                                 
00960200         GENV(VALC,GVLEVEL,GDPLMT); GDPLMT:=GDPLMT+1;                               
00960300       END;                                                                         
00960400     END ELSE BEGIN                                                                 
00960500       IF (FORM(GTYPTR)=FILES) THEN BEGIN                                           
00960600         GACCESS:=INDRCT;                                                           
00960700         GIDPLMT:=0;                                                                
00960800       END ELSE BEGIN                                                               
00960900         GACCESS:=DRCT;                                                             
00961000       END;                                                                         
00961100     END;                                                                           
00961200     IF (PACKED(GTYPTR)=PACKEDSTRUC) THEN BEGIN                                     
00961300       GCHARSIZE := BITS(GTYPTR);                                                   
00961400     END ELSE BEGIN                                                                 
00961500       GCHARSIZE:=BITSPERWORD;                                                      
00961600     END;                                                                           
00961700   FIELD:                                                                           
00961800     IF (OCCUR(DISX) = CREC) THEN BEGIN                                             
00961900       GACCESS:=INDRCT;                                                             
00962000       GVLEVEL:=CLEV(DISX); GDPLMT:=CDSPL(DISX);                                    
00962100       GIDPLMT:=FLDADDR(FORMALIDENTPTR) + CINDX(DISX);                              
00962200       IF(GTYPTR NEQ NIL) THEN BEGIN                                                
00962300         GCHARSIZE:=BITS(GTYPTR);                                                   
00962400         IF(FORM(GTYPTR)=ARRAYS) THEN BEGIN                                         
00962500           IF(GCHARSIZE NEQ BITSPERWORD) THEN BEGIN                                 
00962600             IF(GCHARSIZE NEQ 1) THEN BEGIN                                         
00962700               GIDPLMT:=GIDPLMT*ELSPERWORD(GTYPTR);                                 
00962800               GCHARDESCR:=TRUE;                                                    
00962900             END;                                                                   
00963000           END;                                                                     
00963100         END;                                                                       
00963200       END;                                                                         
00963300     END ELSE IF (OCCUR(DISX) = VREC) THEN BEGIN                                    
00963400       GACCESS:=INXD;                                                               
00963500       GVLEVEL:=VDLEV(DISX); GDPLMT:=VDDSPL(DISX);                                  
00963600       GIDPLMT:=FLDADDR(FORMALIDENTPTR);                                            
00963700       GENV(VALC,VLL(DISX),VDLC(DISX));                                             
00963800       IF (GTYPTR NEQ NIL) THEN BEGIN                                               
00963900         GCHARSIZE := BITS(GTYPTR);                                                 
00964000         IF(FORM(GTYPTR)=ARRAYS) THEN BEGIN                                         
00964100           IF(GCHARSIZE NEQ BITSPERWORD) THEN BEGIN                                 
00964200             IF (GCHARSIZE NEQ 1) THEN BEGIN                                        
00964300               GENLIT(ELSPERWORD(GTYPTR));  GENOP(MULT);                            
00964400               GIDPLMT:=GIDPLMT*ELSPERWORD(GTYPTR);                                 
00964500               GCHARDESCR:=TRUE;                                                    
00964600             END;                                                                   
00964700           END;                                                                     
00964800         END;                                                                       
00964900       END;                                                                         
00965000     END ELSE BEGIN                                                                 
00965100       ERROR(3700);                                                                 
00965200       GTYPTR:=NIL;                                                                 
00965300     END;                                                                           
00965400     IF (PACKEDFIELD(FORMALIDENTPTR)=PACKEDSTRUC) THEN BEGIN                        
00965500       GBITADDR:=BITADDR(FORMALIDENTPTR);                                           
00965600       GBITRANGE:=BITRANGE(FORMALIDENTPTR);                                         
00965700       GPACKEDSUBRFIELD:=FORM(IDTYPE(FORMALIDENTPTR))<=SUBRANGE;                    
00965800     END ELSE BEGIN                                                                 
00965900       GCHARSIZE:=BITSPERWORD;                                                      
00966000     END;                                                                           
00966100   FUNC:                                                                            
00966200     GACCESS:=DRCT;                                                                 
00966300     GVLEVEL:=PFLEV(FORMALIDENTPTR) + 1;                                            
00966400     GDPLMT :=FNCDPLMT(FORMALIDENTPTR);                                             
00966500     GCHARSIZE := BITSPERWORD;                                                      
00966600                                                                                    
00966700   END; % OF CASE OF KLASS                                                          
00966800   IF NOT SYMBOLIN(SELECTSYS OR FSYS) THEN BEGIN                                    
00966900     ERROR(2700); SKIP(SELECTSYS OR FSYS);                                          
00967000   END;                                                                             
00967100   WHILE SYMBOLIN(SELECTSYS) DO BEGIN                                               
00967200 % [                                                                                
00967300     IF (SYMBOL = LBRACK) THEN BEGIN                                                
00967400       DO BEGIN                                                                     
00967500         COPYLATTRGATTR;                                                            
00967600         IF (LTYPTR NEQ NIL) THEN BEGIN                                             
00967700           IF (FORM(LTYPTR) NEQ ARRAYS) THEN BEGIN                                  
00967800             ERROR(2701); LTYPTR:=NIL;                                              
00967900           END;                                                                     
00968000         END;                                                                       
00968100         IF (LTYPTR NEQ NIL) THEN BEGIN                                             
00968200           IF (AELTYPE(LTYPTR) NEQ NIL) THEN BEGIN                                  
00968300             LSIZE := SWORDS(AELTYPE(LTYPTR));                                      
00968400             IF(FORM(AELTYPE(LTYPTR))=ARRAYS) THEN BEGIN                            
00968500               MULTIDIMARRAY := TRUE;                                               
00968600               IF(PACKED(AELTYPE(LTYPTR))=PACKEDSTRUC) THEN BEGIN                   
00968700                 LSIZE:=((LSIZE-1) DIV ELSPERWORD(AELTYPE(LTYPTR))+1) *             
00968800                        ELSPERWORD(AELTYPE(LTYPTR));                                
00968900                 IF (BITS(AELTYPE(LTYPTR)) NEQ BITSPERWORD) THEN BEGIN              
00969000                   IF(BITS(AELTYPE(LTYPTR)) NEQ 1 ) THEN BEGIN                      
00969100                     IF (LACCESS=INXD) THEN BEGIN                                   
00969200                       GENLIT(ELSPERWORD(AELTYPE(LTYPTR)));                         
00969300                       GENOP(MULT);                                                 
00969400                       LCHARDESCR:=TRUE;                                            
00969500                     END ELSE BEGIN                                                 
00969600                       LSIZE:=(LSIZE+ELSPERWORD(AELTYPE(LTYPTR))-1)                 
00969700                              DIV ELSPERWORD(AELTYPE(LTYPTR));                      
00969800                     END;                                                           
00969900                   END;                                                             
00970000                 END;                                                               
00970100               END;                                                                 
00970200             END;                                                                   
00970300             LBITS:=BITS(LTYPTR);                                                   
00970400           END ELSE BEGIN                                                           
00970500             LSIZE := 1;                                                            
00970600             LBITS:=BITSPERWORD;                                                    
00970700           END;                                                                     
00970800         END;                                                                       
00970900         INSYMBOL;                                                                  
00971000         EXPRESSION(FSYS OR COMMARBRACKSET);                                        
00971100         IF (GTYPTR NEQ NIL) THEN BEGIN                                             
00971200           IF (FORM(GTYPTR) > SUBRANGE) THEN ERROR(2702);                           
00971300           IF NOT LCHARDESCR THEN BEGIN                                             
00971400             IF (GKIND=CST) THEN BEGIN                                              
00971500               IF (LCHARSIZE = BITS(LTYPTR)) THEN BEGIN                             
00971600                 IF(FORM(AELTYPE(LTYPTR))=ARRAYS) THEN BEGIN                        
00971700                   IF(PACKED(AELTYPE(LTYPTR))=PACKEDSTRUC) THEN BEGIN               
00971800                     LIDPLMT:=LIDPLMT*ELSPERWORD(AELTYPE(LTYPTR));                  
00971900                     LSIZE:=LSIZE*ELSPERWORD(AELTYPE(LTYPTR));                      
00972000                     LCHARDESCR:=TRUE;                                              
00972100                   END;                                                             
00972200                 END;                                                               
00972300               END ELSE BEGIN                                                       
00972400                 IF(PACKED(LTYPTR)=PACKEDSTRUC) THEN BEGIN                          
00972500                   LIDPLMT:=LIDPLMT*ELSPERWORD(LTYPTR);                             
00972600                 END;                                                               
00972700               END;                                                                 
00972800             END ELSE BEGIN                                                         
00972900               IF(PACKED(LTYPTR)=PACKEDSTRUC) THEN BEGIN                            
00973000                 LIDPLMT:=LIDPLMT*ELSPERWORD(LTYPTR);                               
00973100               END;                                                                 
00973200             END;                                                                   
00973300           END;                                                                     
00973400         END;                                                                       
00973500         IF (LTYPTR NEQ NIL) THEN BEGIN                                             
00973600           LCHARSIZE:=LBITS;                                                        
00973700  $SET OMIT = NOT NAMECOMP                                                          
00973800           IF ASSCOMPTYPES(INXTYPE(LTYPTR),GTYPTR) THEN BEGIN                       
00973900  $POP OMIT                                                                         
00974000  $SET OMIT = NAMECOMP                                                              
00974100           IF COMPTYPES(INXTYPE(LTYPTR),GTYPTR) THEN BEGIN                          
00974200  $POP OMIT                                                                         
00974300             IF (INXTYPE(LTYPTR) NEQ NIL) THEN BEGIN                                
00974400               GETBOUNDS(INXTYPE(LTYPTR),LOWERBOUND,UPPERBOUND);                    
00974500               LIDPLMT:=LIDPLMT - (LOWERBOUND*LSIZE);                               
00974600             END;                                                                   
00974700           END ELSE BEGIN                                                           
00974800             ERROR(2703);                                                           
00974900           END;                                                                     
00975000           IF (GTYPTR NEQ NIL) THEN BEGIN                                           
00975100             IF (GKIND = CST) THEN BEGIN                                            
00975200               IF(PACKED(LTYPTR)=PACKEDSTRUC) THEN BEGIN                            
00975300                 IF(BITS(LTYPTR)=1) THEN BEGIN                                      
00975400                   LIDPLMT:=LIDPLMT+((GCVAL*LSIZE) DIV ELSPERWORD(LTYPTR)           
00975500                     );                                                             
00975600                 END ELSE BEGIN                                                     
00975700                   LIDPLMT:=LIDPLMT+(GCVAL*LSIZE);                                  
00975800                 END;                                                               
00975900                 LBITADDR:=BITSPERWORD-1-((GCVAL-LOWERBOUND)*LBITS                  
00976000                   MOD BITSPERWORD);                                                
00976100               END ELSE BEGIN                                                       
00976200                 LIDPLMT:=LIDPLMT+(GCVAL*LSIZE);                                    
00976300               END;                                                                 
00976400               RANGECHECK(LOWERBOUND,UPPERBOUND,GBMIN,GBMAX);                       
00976500             END ELSE BEGIN                                                         
00976600               LOADV;                                                               
00976700               IF (FORM(INXTYPE(LTYPTR))=SUBRANGE) THEN BEGIN                       
00976800                 IF (FORM(AELTYPE(LTYPTR))=ARRAYS)OR MULTIDIMARRAY THEN             
00976900                 BEGIN                                                              
00977000                   RANGECHECK(LOWERBOUND,UPPERBOUND,GBMIN,GBMAX);                   
00977100                 END;                                                               
00977200               END;                                                                 
00977300               IF(BITS(LTYPTR)=BITSPERWORD) THEN BEGIN                              
00977400                 IF(AELTYPE(LTYPTR) NEQ NIL) THEN BEGIN                             
00977500                   IF(FORM(AELTYPE(LTYPTR))=ARRAYS) THEN BEGIN                      
00977600                     IF(PACKED(AELTYPE(LTYPTR))=PACKEDSTRUC) THEN BEGIN             
00977700                       IF(BITS(AELTYPE(LTYPTR)) NEQ 1) THEN BEGIN                   
00977800                         IF NOT LCHARDESCR THEN BEGIN                               
00977900                           LIDPLMT:=LIDPLMT*ELSPERWORD(AELTYPE(LTYPTR));            
00978000                           LCHARDESCR:=TRUE;                                        
00978100                         END;                                                       
00978200                         IF(BITS(AELTYPE(LTYPTR))=4) OR                             
00978300                           (BITS(AELTYPE(LTYPTR))=6) OR                             
00978400                           (BITS(AELTYPE(LTYPTR))=8) THEN BEGIN                     
00978500                           IF (LACCESS=INDRCT) THEN BEGIN                           
00978600                             GENLIT(ELSPERWORD(AELTYPE(LTYPTR))*LSIZE);             
00978700                           END ELSE BEGIN                                           
00978800                             GENLIT(LSIZE);                                         
00978900                           END;                                                     
00979000                           GENOP(MULT);                                             
00979100                         END ELSE BEGIN                                             
00979200                           IF (LSIZE NEQ 1)                                         
00979300                           THEN BEGIN                                               
00979400                             GENLIT(LSIZE);                                         
00979500                             GENOP(MULT);                                           
00979600                           END;                                                     
00979700                         END;                                                       
00979800                       END;                                                         
00979900                     END ELSE BEGIN                                                 
00980000                       IF (LSIZE NEQ 1) THEN BEGIN                                  
00980100                         GENLIT(LSIZE); GENOP(MULT);                                
00980200                       END;                                                         
00980300                     END;                                                           
00980400                   END ELSE BEGIN                                                   
00980500                     IF (LSIZE NEQ 1) THEN BEGIN                                    
00980600                       GENLIT(LSIZE); GENOP(MULT);                                  
00980700                     END;                                                           
00980800                   END;                                                             
00980900                 END ELSE BEGIN                                                     
00981000                   IF (LSIZE NEQ 1) THEN BEGIN                                      
00981100                     GENLIT(LSIZE); GENOP(MULT);                                    
00981200                   END;                                                             
00981300                 END;                                                               
00981400               END ELSE BEGIN                                                       
00981500                 IF (LSIZE NEQ 1) THEN BEGIN                                        
00981600                   GENLIT(LSIZE); GENOP(MULT);                                      
00981700                 END;                                                               
00981800               END;                                                                 
00981900               IF (LACCESS = INXD) THEN GENOP(ADD) ELSE LACCESS:=INXD;              
00982000             END;                                                                   
00982100           END;                                                                     
00982200           COPYGATTRLATTR;                                                          
00982300           GPACKEDARRAY:=(PACKED(GTYPTR)=PACKEDSTRUC);                              
00982400           GTYPTR:=AELTYPE(GTYPTR);                                                 
00982500         END;                                                                       
00982600       END UNTIL (SYMBOL NEQ COMMA);                                                
00982700       IF (SYMBOL = RBRACK) THEN INSYMBOL ELSE ERROR(2704);                         
00982800 % .                                                                                
00982900     END ELSE IF (SYMBOL = PERIOD) THEN BEGIN                                       
00983000       MULTIDIMARRAY := FALSE;                                                      
00983100       IF (GTYPTR NEQ NIL) THEN BEGIN                                               
00983200         IF (FORM(GTYPTR) NEQ RECORDS) THEN BEGIN                                   
00983300           ERROR(2705); GTYPTR:=NIL;                                                
00983400         END;                                                                       
00983500         INSYMBOL;                                                                  
00983600         IF (SYMBOL = IDENT) THEN BEGIN                                             
00983700           IF (GTYPTR NEQ NIL) THEN BEGIN                                           
00983800             SEARCHSECTION(FSTFLD(GTYPTR),IDENTIFIERPTR);                           
00983900             IF (IDENTIFIERPTR = NIL) THEN BEGIN                                    
00984000               ERROR(2706); GTYPTR:=NIL;                                            
00984100             END ELSE BEGIN                                                         
00984200               GTYPTR:=IDTYPE(IDENTIFIERPTR);                                       
00984300               IF (FORM(GTYPTR) < POWER) THEN BEGIN                                 
00984400                 IF (GTYPTR NEQ NIL) THEN BEGIN                                     
00984500                   IF (PACKEDFIELD(IDENTIFIERPTR) = PACKEDSTRUC) THEN               
00984600                      BEGIN                                                         
00984700                     GBITADDR:=BITADDR(IDENTIFIERPTR);                              
00984800                     GBITRANGE:=BITRANGE(IDENTIFIERPTR);                            
00984900                     GPACKEDSUBRFIELD:=(FORM(GTYPTR)<=SUBRANGE);                    
00985000                   END;                                                             
00985100                 END;                                                               
00985200               END ELSE BEGIN                                                       
00985300                 IF(FORM(GTYPTR) = ARRAYS) THEN BEGIN                               
00985400                   GCHARSIZE:=BITS(GTYPTR);                                         
00985500                   IF(PACKED(GTYPTR) = PACKEDSTRUC) THEN BEGIN                      
00985600                     IF(BITS(GTYPTR) NEQ BITSPERWORD) THEN BEGIN                    
00985700                       IF(GCHARSIZE NEQ 1) THEN BEGIN                               
00985800                         IF (GACCESS = INXD) THEN BEGIN                             
00985900                           GENLIT(ELSPERWORD(GTYPTR));                              
00986000                           GENOP(MULT);                                             
00986100                           IF NOT GCHARDESCR THEN BEGIN                             
00986200                             GIDPLMT:=GIDPLMT*ELSPERWORD(GTYPTR);                   
00986300                           END;                                                     
00986400                         END ELSE BEGIN                                             
00986500                           IF (GACCESS=INDRCT) THEN BEGIN                           
00986600                             IF NOT GCHARDESCR THEN BEGIN                           
00986700                               GIDPLMT:=GIDPLMT*ELSPERWORD(GTYPTR);                 
00986800                             END;                                                   
00986900                           END;                                                     
00987000                         END;                                                       
00987100                         GCHARDESCR:= TRUE;                                         
00987200                       END;                                                         
00987300                     END;                                                           
00987400                   END;                                                             
00987500                 END;                                                               
00987600               END;                                                                 
00987700               CASE GACCESS OF BEGIN                                                
00987800                 %                                                                  
00987900               INDRCT:                                                              
00988000               INXD:                                                                
00988100                 IF GCHARDESCR THEN BEGIN                                           
00988200                   GIDPLMT:=GIDPLMT+FLDADDR(IDENTIFIERPTR)*ELSPERWORD               
00988300                     (GTYPTR);                                                      
00988400                 END ELSE BEGIN                                                     
00988500                   GIDPLMT:=GIDPLMT+FLDADDR(IDENTIFIERPTR);                         
00988600                 END;                                                               
00988700               ELSE:                                                                
00988800                 ERROR(3707);                                                       
00988900               END; % OF CASE                                                       
00989000             END; % OF IF IDENTIFIERPTR                                             
00989100           END; % OF IF GTYPTR                                                      
00989200         END ELSE BEGIN                                                             
00989300           ERROR(2708);                                                             
00989400         END;                                                                       
00989500       END;                                                                         
00989600       INSYMBOL;                                                                    
00989700 % @                                                                                
00989800     END ELSE BEGIN                                                                 
00989900       MULTIDIMARRAY := FALSE;                                                      
00990000       IF (GTYPTR NEQ NIL) THEN BEGIN                                               
00990100         IF (FORM(GTYPTR) = POINTERS) THEN BEGIN                                    
00990200           LOADV;                                                                   
00990300           GTYPTR:=ELTYPE(GTYPTR);                                                  
00990400           GKIND:=VARBL; GACCESS:=INXD; GIDPLMT:=0;                                 
00990500           GVLEVEL:=BASELVL; GDPLMT:=ADDRHEAP;                                      
00990600         END ELSE IF (FORM(GTYPTR) = FILES) THEN BEGIN                              
00990700           IF (FILTYPE(GTYPTR)=CHARBUFPTR) THEN BEGIN                               
00990800             GTYPTR:=CHARPTR;                                                       
00990900             GENV(NAMC,GVLEVEL,GDPLMT+2);                                           
00991000             GENOP1(LT8,6);                                                         
00991100             GENOP(NXLV);                                                           
00991200             GPACKEDARRAY:=TRUE;                                                    
00991300             GACCESS:=INXD;                                                         
00991400           END ELSE BEGIN                                                           
00991500             IF(FILTYPE(GTYPTR)=WORDBUFPTR) THEN BEGIN                              
00991600               GTYPTR:=ORIGFILTYPE(GTYPTR);   %INT REAL BOOL                        
00991700               GENOP1(LT8,3);                                                       
00991800               GENV(NAMC,GVLEVEL,GDPLMT+2);                                         
00991900               GENOP(NXLV);                                                         
00992000               GACCESS:=INXD;                                                       
00992100             END ELSE BEGIN                                                         
00992200               GACCESS:=INDRCT;                                                     
00992300               GTYPTR:=FILTYPE(GTYPTR);                                             
00992400             END;                                                                   
00992500           END;                                                                     
00992600           GKIND:=VARBL;                                                            
00992700           GDPLMT := GDPLMT+1;         %POINT TO BUFFER                             
00992800           GIDPLMT:=0;                                                              
00992900           GCHARSIZE:=BITS(GTYPTR);                                                 
00993000         END ELSE BEGIN                                                             
00993100           ERROR(2709);                                                             
00993200         END;                                                                       
00993300       END;                                                                         
00993400       INSYMBOL;                                                                    
00993500     END;                                                                           
00993600     CHECKIN((FSYS OR SELECTSYS),2707);                                             
00993700   END; % OF WHILE                                                                  
00993800 END; % OF SELECTOR                                                                 
00993900                                                                                    
00994000                                                                                    
00994100                                                                                    
00994200 PROCEDURE BOUNDSCHECK(MINB,MAXB,READING);                                          
00994300 %         ***********                                                              
00994400 VALUE MINB,MAXB,READING;                                                           
00994500 INTEGER MINB,MAXB;                                                                 
00994600 BOOLEAN READING;                                                                   
00994700 BEGIN                                                                              
00994800 INTEGER                                                                            
00994900   LABA,LABB;                                                                       
00995000   IF(GKIND=CST) THEN BEGIN                                                         
00995100     IF((GCVAL<MINB) OR (GCVAL>MAXB)) THEN BEGIN                                    
00995200       ERROR(2841);                                                                 
00995300     END;                                                                           
00995400   END ELSE  BEGIN                                                                  
00995500     IF NOT READING THEN BEGIN                                                      
00995600       IF(FORM(GTYPTR)<POWER) OR SHORTSET(GTYPTR) THEN LOADV                        
00995700       ELSE LOADSTRINGDESCRIPTOR;                                                   
00995800     END;                                                                           
00995900     LABA:=MAKELABEL;                                                               
00996000     LABB:=MAKELABEL;                                                               
00996100     GENOP(DUPL);                                                                   
00996200     GENLIT(MINB);                                                                  
00996300     GENOP(LESS);                                                                   
00996400     GENBR(BRFL,LABA);                                                              
00996500     GENLABEL(LABB);                                                                
00996600     RUNTIMEERROR(BOUNDSERROR);                                                     
00996700     GENLABEL(LABA);                                                                
00996800     GENOP(DUPL);                                                                   
00996900     GENLIT(MAXB);                                                                  
00997000     GENOP(GRTR);                                                                   
00997100     GENBR(BRTR,LABB);                                                              
00997200     IF(FORM(GTYPTR)>POWER)OR LONGSET(GTYPTR) THEN GENOP(DLET);                     
00997300   END;                                                                             
00997400 END;   %OF BOUNDSCHECK                                                             
00997500                                                                                    
00997600 PROCEDURE SETEXPRBOUNDS(LMIN,LMAX,GMIN,GMAX,FOP);                                  
00997700 %         *********                                                                
00997800 VALUE LMIN,LMAX,FOP;                                                               
00997900 REAL LMIN,LMAX,GMIN,GMAX;                                                          
00998000 TYPEOPERATOR FOP;                                                                  
00998100 BEGIN                                                                              
00998200 REAL                                                                               
00998300   RMIN,RMAX,RESULT,SAVEGMIN;                                                       
00998400 INTEGER ERRCOUNT;                                                                  
00998500                                                                                    
00998600 PROCEDURE TRYPRODUCT(A,B,ERRCOUNT);                                                
00998700 %         **********                                                               
00998800 VALUE A,B;                                                                         
00998900 REAL A,B;                                                                          
00999000 INTEGER ERRCOUNT;                                                                  
00999100 BEGIN                                                                              
00999200   IF (B NEQ 0) THEN BEGIN                                                          
00999300     IF (ABS(A) > MAXINT DIV ABS(B)) THEN BEGIN                                     
00999400       RESULT := SIGN(A) * SIGN(B) * (MAXINT+1);   %OVERFLOW;                       
00999500       IF (A>0 AND B>0) OR (A<0 AND B<0) THEN ERRORCOUNT := *+1                     
00999600                                         ELSE ERRORCOUNT := *-1;                    
00999700     END ELSE BEGIN                                                                 
00999800       RESULT := A*B;                                                               
00999900     END;                                                                           
01000000   END ELSE BEGIN                                                                   
01000100     RESULT := A*B;                                                                 
01000200   END;                                                                             
01000300   IF (RESULT < RMIN) THEN RMIN:=RESULT;                                            
01000400   IF (RESULT > RMAX) THEN RMAX := RESULT;                                          
01000500 END;   %OF TRYPRODUCT                                                              
01000600                                                                                    
01000700 PROCEDURE TRYQUOTIENT(A,B);                                                        
01000800 %         ***********                                                              
01000900 VALUE A,B;                                                                         
01001000 REAL A,B;                                                                          
01001100 BEGIN                                                                              
01001200   RESULT := A DIV B;                                                               
01001300   IF (RESULT < RMIN) THEN RMIN := RESULT;                                          
01001400   IF (RESULT > RMAX) THEN RMAX := RESULT;                                          
01001500 END;   %OF TRYQUOTIENT                                                             
01001600                                                                                    
01001700   CASE FOP OF BEGIN                                                                
01001800   PLUS:                                                                            
01001900     GMIN := GMIN + LMIN;                                                           
01002000     GMAX := GMAX + LMAX;                                                           
01002100   MINUS:                                                                           
01002200     SAVEGMIN:=GMIN;                                                                
01002300     GMIN := LMIN - GMAX;                                                           
01002400     GMAX := LMAX - SAVEGMIN;                                                       
01002500   MUL:                                                                             
01002600     RMIN := MAXINT;                                                                
01002700     RMAX := -MAXINT;                                                               
01002800     ERRCOUNT := 0;                                                                 
01002900     TRYPRODUCT(LMIN,GMIN,ERRCOUNT);                                                
01003000     TRYPRODUCT(LMIN,GMAX,ERRCOUNT);                                                
01003100     TRYPRODUCT(LMAX,GMIN,ERRCOUNT);                                                
01003200     TRYPRODUCT(LMAX,GMAX,ERRCOUNT);                                                
01003300     GMIN:=RMIN;                                                                    
01003400     GMAX:=RMAX;                                                                    
01003500     IF (ERRCOUNT=4) OR (ERRORCOUNT=-4) THEN ERROR(2790);                           
01003600   JDIV:                                                                            
01003700     RMIN:=MAXINT;                                                                  
01003800     RMAX:=-MAXINT;                                                                 
01003900     IF (GMIN NEQ 0) THEN BEGIN                                                     
01004000       TRYQUOTIENT(LMIN,GMIN);                                                      
01004100       TRYQUOTIENT(LMAX,GMIN);                                                      
01004200     END;                                                                           
01004300     IF (GMAX NEQ 0) THEN BEGIN                                                     
01004400       TRYQUOTIENT(LMIN,GMAX);                                                      
01004500       TRYQUOTIENT(LMAX,GMAX);                                                      
01004600     END;                                                                           
01004700     IF ((GMIN=0) AND (GMAX=0)) THEN ERROR(2791);                                   
01004800     GMIN:= RMIN;  GMAX:=RMAX;                                                      
01004900   IMOD:                                                                            
01005000     IF ((GMIN=0) AND (GMAX=0)) THEN BEGIN                                          
01005100       ERROR(2791);                                                                 
01005200     END ELSE BEGIN                                                                 
01005300       IF (LMIN=LMAX) AND (GMIN=GMAX) THEN BEGIN                                    
01005400         RMIN := RMAX := LMIN MOD RMIN;                                             
01005500       END ELSE BEGIN                                                               
01005600         RMIN := RMAX := 0;                                                         
01005700         IF (LMIN<0) AND (GMIN<0) THEN BEGIN                                        
01005800           IF (LMIN<GMIN) THEN BEGIN                                                
01005900             IF (GMIN+1 < RMIN) THEN RMIN := GMIN+1;                                
01006000           END ELSE BEGIN                                                           
01006100             IF (LMIN<RMIN) THEN RMIN := LMIN;                                      
01006200           END;                                                                     
01006300         END;                                                                       
01006400         IF (LMIN<0) AND (GMAX>0) THEN BEGIN                                        
01006500           IF (-LMIN > GMAX) THEN BEGIN                                             
01006600             IF (-GMAX+1 < RMIN) THEN RMIN := -GMAX+1;                              
01006700           END ELSE BEGIN                                                           
01006800             IF (LMIN < RMIN) THEN RMIN := LMIN;                                    
01006900           END;                                                                     
01007000         END;                                                                       
01007100         IF (LMAX > 0) AND (GMIN < 0) THEN BEGIN                                    
01007200           IF (LMAX >= -GMIN) THEN BEGIN                                            
01007300             IF (-GMIN-1 > RMAX) THEN RMAX := -GMIN-1;                              
01007400           END ELSE BEGIN                                                           
01007500             IF (LMAX > GMAX) THEN RMAX := LMAX;                                    
01007600           END;                                                                     
01007700         END;                                                                       
01007800         IF (LMAX>0) AND (GMAX > 0) THEN BEGIN                                      
01007900           IF (LMAX >= GMAX) THEN BEGIN                                             
01008000             IF (GMAX-1 > RMAX) THEN RMAX := GMAX-1;                                
01008100           END ELSE BEGIN                                                           
01008200             IF (LMAX > RMAX) THEN RMAX := LMAX;                                    
01008300           END;                                                                     
01008400         END;                                                                       
01008500         GMIN := RMIN;  GMAX := RMAX;                                               
01008600       END;                                                                         
01008700     END;                                                                           
01008800   END;   % OF CASE                                                                 
01008900 END;   %OF SETEXPRBOUNDS                                                           
01009000                                                                                    
01009100                                                                                    
01009200 %-----------------------------------------------------------------------           
01009300                                                                                    
01009400 % FOLLOWING PROCESS HANDLES STREM ORIENTED I/O                                     
01009500                                                                                    
01009600 %------------------------------------------------------------------                
01009700                                                                                    
01009800 PROCEDURE STREAMIO(LKEY);                                                          
01009900 %         *********                                                                
01010000 VALUE LKEY; INTEGER LKEY;                                                          
01010100 BEGIN                                                                              
01010200 DEFINE                                                                             
01010300   READSTATEMENT = (LKEY = 6)#,                                                     
01010400   WRITESTATEMENT = (LKEY = 7)#,                                                    
01010500   GET = (LKEY=1)#,                                                                 
01010600   PUT = (LKEY=2)#,                                                                 
01010700   GETPUT = (GET OR PUT)#,                                                          
01010800   ARRAYSIZE = (SWORDS(FILTYPE(IDTYPE(LCP))))#,                                     
01010900   READLN = (LKEY=15)#,                                                             
01011000   WRITELN = (LKEY=16)#;                                                            
01011100 INTEGER                                                                            
01011200   FILELEV,                                                                         
01011300   FILEADDR;                                                                        
01011400 BOOLEAN                                                                            
01011500   TEXTF,                                                                           
01011600   SIMPLECOMP;                                                                      
01011700                                                                                    
01011800 PROCEDURE CREATED1RECORD(FTYPTR);                                                  
01011900 %         ==============                                                           
01012000 VALUE FTYPTR; TYPESTRUCTPTR FTYPTR;                                                
01012100 BEGIN                                                                              
01012200   DEFINE                                                                           
01012300     SIZESCALARARRAY=1024#;                                                         
01012400   ARRAY                                                                            
01012500     DESCRIPT[0:SIZESCALARARRAY-1];                                                 
01012600   POINTER                                                                          
01012700     PTR;                                                                           
01012800   TYPEIDENTPTR                                                                     
01012900     LCP;                                                                           
01013000   TYPEIDENTPTR ARRAY                                                               
01013100     IDPTRS[0:SIZESCALARARRAY-1];                                                   
01013200   INTEGER                                                                          
01013300     LENGNAME,                                                                      
01013400     LENGSEG,                                                                       
01013500     NOSCALARS,                                                                     
01013600     I;                                                                             
01013700                                                                                    
01013800   LENGSEG:=0;                                                                      
01013900   NOSCALARS:=0;                                                                    
01014000   LCP:=FCONST(FTYPTR);                                                             
01014100   DO BEGIN                                                                         
01014200     IDPTRS[NOSCALARS]:=LCP;                                                        
01014300     NOSCALARS:=*+1;                                                                
01014400     LCP:=NEXT(LCP);                                                                
01014500   END UNTIL (LCP=NIL);                                                             
01014600   PTR:=DESCRIPT[0];                                                                
01014700   NOSCALARS:=*-1;                                                                  
01014800   WHILE (NOSCALARS>=0) DO BEGIN                                                    
01014900     LENGNAME:=HEAP[NAME(IDPTRS[NOSCALARS])].[47:8]-1;                              
01015000     REPLACE PTR:PTR BY LENGNAME.[7:48] FOR 1,                                      
01015100           POINTER(HEAP[NAME(IDPTRS[NOSCALARS])])+1 FOR LENGNAME;                   
01015200     LENGSEG:=*+LENGNAME+1;                                                         
01015300     NOSCALARS:=*-1;                                                                
01015400   END;                                                                             
01015500   REPLACE PTR BY 48"00" FOR 1;                                                     
01015600   LENGSEG:=*+1;                                                                    
01015700   BEGINNEWSEGMENT(WORDSEGTYPE);                                                    
01015800   LENGSEG:=(LENGSEG DIV CHARSPERWORD)+1;                                           
01015900   FOR I:=0 STEP 1 UNTIL (LENGSEG-1) DO GENWORD(DESCRIPT[I]);                       
01016000   SD1DISP(FTYPTR):=SEGNUMBER;                                                      
01016100   SIO(FTYPTR):=D1SLOT;                                                             
01016200   IF CODETOG THEN BEGIN                                                            
01016300     REPLACE LBUF0 BY "(01,",                                                       
01016400       SEGNUMBER FOR 5 DIGITS,                                                      
01016500       ") = SCALAR I/O STRING";                                                     
01016600     WRITELBUFFER;                                                                  
01016700   END;                                                                             
01016800   CLOSESEGMENT;                                                                    
01016900 END;                                                                               
01017000                                                                                    
01017100 %-----------------------------------------------------------------------           
01017200                                                                                    
01017300 % THIS SECTION HANDLES I/O ON A FILE OF A STRUCTURED TYPE                          
01017400 % EG. FILE OF PACKED ARRAY....                                                     
01017500 %     FILE OF RECORD...                                                            
01017600 %                                                                                  
01017700                                                                                    
01017800 %-----------------------------------------------------------------------           
01017900                                                                                    
01018000 PROCEDURE STRUCTFILEIO;                                                            
01018100 %         ============                                                             
01018200 BEGIN                                                                              
01018300   INTEGER LAB,LCPCW;                                                               
01018400   BOOLEAN FLAG;                                                                    
01018500                                                                                    
01018600 PROCEDURE STRUCTFILEIOLIST (LCPCW);                                                
01018700 %         ================                                                         
01018800 INTEGER LCPCW;                                                                     
01018900 BEGIN                                                                              
01019000   INTEGER DESCR,LABELA,TYPE,LMIN,LMAX;                                             
01019100   REAL PCWPOSN;                                                                    
01019200   TYPEIDENTPTR LCP;                                                                
01019300   TYPESTRUCTPTR CHARTYPE;                                                          
01019400   BOOLEAN SIMPLEELEMENT;                                                           
01019500   DEFINE                                                                           
01019600     SIMPLEVAR = (GTYPTR=REALPTR OR GTYPTR=INTPTR                                   
01019700                  OR GTYPTR=BOOLPTR OR GTYPTR=CHARPTR)#,                            
01019800     PTRSET=((FORM(GTYPTR)=POINTERS) OR (SHORTSET(GTYPTR)))#,                       
01019900     RADIXTYPE = (TYPE = 5)#,                                                       
01020000     DEFAULTW = 0#,                                                                 
01020100     DEFAULTD = 0#;                                                                 
01020200                                                                                    
01020300   LEXLEVEL := *+1;                                                                 
01020400   LABELA := MAKELABEL;                                                             
01020500   GENLABEL(LABELA);                                                                
01020600   PCWPOSN := ASKFORPCW(LABELA) & 0[47:1];                                          
01020700   IF READSTATEMENT OR READLN THEN BEGIN                                            
01020800     WHILE ((SYMBOL = IDENT) OR (SYMBOL=LPARENT)) DO BEGIN                          
01020900       PRTERR:=FALSE;   % STOP UNDEFINED MESSAGE WTICE                              
01021000       SEARCHID(KONSTVARFLDFNCSET,LCP);    %FOR FOR CHECK                           
01021100       PRTERR:=TRUE;                                                                
01021200       EXPRESSION(FSYS OR COMMARPARENTSET);                                         
01021300       LOADADDRIFINXD;                                                              
01021400       GENOP(MKST);                                                                 
01021500       GENV(NAMC,LEXLEVEL,IF SIMPLEVAR OR(FORM(GTYPTR)=SUBRANGE) THEN 2             
01021600               ELSE 3);                                                             
01021700       IF SIMPLEVAR THEN BEGIN                                                      
01021800         DESCR := IF (GTYPTR = INTPTR) THEN 1                                       
01021900                  ELSE IF (GTYPTR = REALPTR) THEN 2                                 
01022000                  ELSE IF (GTYPTR = CHARPTR) THEN 0                                 
01022100                  ELSE IF (GTYPTR = BOOLPTR) THEN 4                                 
01022200                  ELSE 2;        %DEFAULT                                           
01022300         GENLIT(DESCR);                                                             
01022400       END ELSE BEGIN                                                               
01022500         IF(FORM(GTYPTR)=SCALAR) THEN BEGIN                                         
01022600           IF NOT(BOOLEAN(SIO(GTYPTR))) THEN BEGIN                                  
01022700             CREATED1RECORD(GTYPTR);                                                
01022800           END;                                                                     
01022900           GENOP(ZERO);                                                             
01023000           GENV(NAMC,1,SD1DISP(GTYPTR));                                            
01023100           GENOP(INDX);                                                             
01023200           GENOP1(BSET,42);                                                         
01023300         END ELSE BEGIN                                                             
01023400           IF(FORM(GTYPTR) = SUBRANGE) THEN BEGIN                                   
01023500             DESCR := IF (RANGETYPE(GTYPTR) = INTPTR) THEN 1                        
01023600                      ELSE IF (RANGETYPE(GTYPTR) = REALPTR) THEN 2                  
01023700                      ELSE IF (RANGETYPE(GTYPTR) = CHARPTR) THEN 0                  
01023800                      ELSE IF (RANGETYPE(GTYPTR) = BOOLPTR) THEN 4                  
01023900                      ELSE 2;        %DEFAULT                                       
01024000             GENLIT(DESCR);                                                         
01024100           END ELSE BEGIN                                                           
01024200             ERROR(2933);                                                           
01024300           END;                                                                     
01024400         END;                                                                       
01024500       END;                                                                         
01024600       GENOP(ENTR);                                                                 
01024700       IF (FORM(GTYPTR)=SUBRANGE) THEN BEGIN                                        
01024800         IF BOUNDSCHECKTOG THEN BEGIN                                               
01024900           GETBOUNDS(GTYPTR,LMIN,LMAX);                                             
01025000           BOUNDSCHECK(LMIN,LMAX,TRUE);                                             
01025100         END;                                                                       
01025200       END;                                                                         
01025300       IF(FORM(IDTYPE(LCP))>POWER) OR (FORM(IDTYPE(LCP))=POINTERS) THEN             
01025400       BEGIN                                                                        
01025500         CASE GCHARSIZE OF BEGIN                                                    
01025600         1:48: STORE(GATTRPARAMETERS,STOD);                                         
01025700         4:6:8: STORE(GATTRPARAMETERS,TUND);                                        
01025800         END;                                                                       
01025900       END ELSE BEGIN                                                               
01026000         STORE(GATTRPARAMETERS,STOD);                                               
01026100       END;                                                                         
01026200       IF (VFORCONTRL(LCP)=REAL(TRUE)) THEN BEGIN                                   
01026300         ERROR(2936);                                                               
01026400       END;                                                                         
01026500       IF (SYMBOL = COMMA) THEN INSYMBOL;                                           
01026600     END;                                                                           
01026700   END ELSE BEGIN                                                                   
01026800     WHILE (SYMBOLIN(SIMPTYPEBEGSYS) OR (SYMBOL=NOTSY)) DO BEGIN                    
01026900       EXPRESSION(FSYS OR COMMACOLONRPARENTSET);                                    
01027000       IF (NOT SIMPLEVAR) AND (STRING(GTYPTR)) THEN BEGIN                           
01027100         IF (GVLEVEL = 1) THEN BEGIN                                                
01027200           GENLIT(GIDPLMT);                                                         
01027300           GENV(NAMC,GVLEVEL,GDPLMT);                                               
01027400         END ELSE BEGIN                                                             
01027500           LOADIRW;                                                                 
01027600         END;                                                                       
01027700         GENOP(INDX);                                                               
01027800       END ELSE                                                                     
01027900       IF ((GACCESS=DRCT) OR (GKIND=CST) OR (GCHARSIZE=1) OR                        
01028000         GPACKEDSUBRFIELD OR GPACKEDARRAY) THEN BEGIN                               
01028100         LOADV;                                                                     
01028200       END ELSE BEGIN                                                               
01028300         LOADIRW;                                                                   
01028400       END;                                                                         
01028500       GENV(NAMC,LEXLEVEL,IF SIMPLEVAR THEN 2 ELSE                                  
01028600          IF(STRING(GTYPTR)) THEN 3                                                 
01028700          ELSE IF FORM(GTYPTR)=SCALAR THEN 4 ELSE 2);                               
01028800       GENOP(EXCH);                                                                 
01028900       GENOP(IMKS);                                                                 
01029000       CHARTYPE := GTYPTR;                                                          
01029100       IF (FORM(GTYPTR)=SUBRANGE) THEN BEGIN                                        
01029200         CHARTYPE:=RANGETYPE(GTYPTR);                                               
01029300       END;                                                                         
01029400       IF(STRING(GTYPTR)) THEN BEGIN                                                
01029500         GENLIT(SWORDS(GTYPTR));                                                    
01029600         IF ASCIITOG THEN GENOP(ONE)                                                
01029700                     ELSE GENOP(ZERO);                                              
01029800       END ELSE BEGIN                                                               
01029900         IF (SIMPLEVAR OR PTRSET OR (FORM(GTYPTR)=SUBRANGE)) THEN BEGIN             
01030000           TYPE :=  IF(CHARTYPE=CHARPTR) THEN 0                                     
01030100                    ELSE IF (CHARTYPE=INTPTR) THEN 1                                
01030200                         ELSE IF (CHARTYPE=BOOLPTR)THEN 4                           
01030300                             ELSE 2;                                                
01030400           SIMPLEELEMENT := TRUE;                                                   
01030500         END ELSE BEGIN                                                             
01030600           IF(FORM(GTYPTR)=SCALAR) THEN BEGIN                                       
01030700             IF NOT BOOLEAN(SIO(GTYPTR)) THEN BEGIN                                 
01030800               CREATED1RECORD(GTYPTR);                                              
01030900             END;                                                                   
01031000             GENOP(ZERO);                                                           
01031100             GENV(NAMC,1,SD1DISP(GTYPTR));                                          
01031200             GENOP(INDX);                                                           
01031300             GENOP1(BSET,42);                                                       
01031400             IF STANDARDTOG THEN ERROR(1934);                                       
01031500           END ELSE BEGIN                                                           
01031600             ERROR(2935);                                                           
01031700           END;                                                                     
01031800         END;                                                                       
01031900       END;                                                                         
01032000       IF (SIMPLEVAR OR PTRSET OR (FORM(GTYPTR)=SUBRANGE)) THEN BEGIN               
01032100         IF SYMBOLIN(COMMARPARENTSET) THEN BEGIN                                    
01032200           GENLIT(TYPE);                                                            
01032300           GENLIT(DEFAULTW);                                                        
01032400           IF (CHARTYPE = CHARPTR) THEN BEGIN                                       
01032500             IF ASCIITOG THEN BEGIN                                                 
01032600               GENOP(ONE);                                                          
01032700             END ELSE BEGIN                                                         
01032800               GENLIT(DEFAULTD);                                                    
01032900             END;                                                                   
01033000           END ELSE BEGIN                                                           
01033100             GENLIT(DEFAULTD);                                                      
01033200           END;                                                                     
01033300         END ELSE BEGIN                                                             
01033400           IF (SYMBOL = COLON) THEN BEGIN                                           
01033500             INSYMBOL;                                                              
01033600             IF (SYMBOL=COLON) THEN BEGIN                                           
01033700               IF(SIMPLEELEMENT OR FORM(CHARTYPE)=SCALAR) THEN BEGIN                
01033800                 TYPE:=5;                                                           
01033900                 IF STANDARDTOG THEN ERROR(1938);                                   
01034000               END ELSE ERROR(2930);                                                
01034100               INSYMBOL;                                                            
01034200             END;                                                                   
01034300             IF(SYMBOLIN(SIMPTYPEBEGSYS)) THEN BEGIN                                
01034400               EXPRESSION(FSYS OR COMMACOLONRPARENTSET);                            
01034500               LOADV;                                                               
01034600             END ELSE BEGIN                                                         
01034700               ERROR(2931);                                                         
01034800             END;                                                                   
01034900             IF (SYMBOL=COLON) THEN BEGIN                                           
01035000               GENLIT(TYPE);   GENOP(EXCH);                                         
01035100               INSYMBOL;                                                            
01035200               IF NOT (SIMPLEELEMENT OR RADIXTYPE) THEN BEGIN                       
01035300                 ERROR(2932);                                                       
01035400               END;                                                                 
01035500               IF(SYMBOLIN(SIMPTYPEBEGSYS)) THEN BEGIN                              
01035600                 EXPRESSION(FSYS OR COMMACOLONRPARENTSET);                          
01035700                 LOADV;                                                             
01035800               END ELSE BEGIN                                                       
01035900                 ERROR(2931);                                                       
01036000               END;                                                                 
01036100             END ELSE BEGIN                                                         
01036200               IF (TYPE=2) THEN BEGIN                                               
01036300                 GENLIT(3);                                                         
01036400               END ELSE BEGIN                                                       
01036500                 GENLIT(TYPE);                                                      
01036600               END;                                                                 
01036700               GENOP(EXCH);                                                         
01036800               IF (CHARTYPE = CHARPTR) THEN BEGIN                                   
01036900                 IF ASCIITOG THEN BEGIN                                             
01037000                   GENOP(ONE);                                                      
01037100                 END ELSE BEGIN                                                     
01037200                   GENLIT(DEFAULTD);                                                
01037300                 END;                                                               
01037400               END ELSE BEGIN                                                       
01037500                 GENLIT(DEFAULTD);                                                  
01037600               END;                                                                 
01037700             END;                                                                   
01037800           END;                                                                     
01037900         END;                                                                       
01038000       END ELSE BEGIN                                                               
01038100         IF SYMBOLIN(COMMARPARENTSET) THEN BEGIN                                    
01038200           GENLIT(DEFAULTW);                                                        
01038300         END ELSE BEGIN                                                             
01038400           IF (SYMBOL=COLON) THEN BEGIN                                             
01038500             INSYMBOL;                                                              
01038600             IF (SYMBOLIN(SIMPTYPEBEGSYS)) THEN BEGIN                               
01038700               EXPRESSION(FSYS OR COMMACOLONRPARENTSET);                            
01038800               LOADV;                                                               
01038900             END ELSE BEGIN                                                         
01039000               ERROR(2931);                                                         
01039100             END;                                                                   
01039200           END ELSE BEGIN                                                           
01039300             GENLIT(DEFAULTW);                                                      
01039400           END;                                                                     
01039500         END;                                                                       
01039600       END;                                                                         
01039700       GENOP(ENTR);                                                                 
01039800       IF (SYMBOL=COMMA) THEN BEGIN                                                 
01039900         INSYMBOL;                                                                  
01040000       END;                                                                         
01040100     END;   %OF WHILE                                                               
01040200   END;                                                                             
01040300   GENERATEPCWWORD(PCWPOSN,NIL);                                                    
01040400   LCPCW := LC;                                                                     
01040500   LEXLEVEL := *-1;                                                                 
01040600   IF CODETOG THEN BEGIN                                                            
01040700     REPLACE LBUF0 BY                                                               
01040800       "(", LEXLEVEL FOR 2 DIGITS,                                                  
01040900       ",", LC FOR 5 DIGITS,                                                        
01041000       ") = PASCAL I/O LIST PCW";                                                   
01041100     WRITELBUFFER;                                                                  
01041200   END;                                                                             
01041300   LC := LC + 1;                                                                    
01041400   IF (READLN OR WRITELN) THEN GENOP(ONE)                                           
01041500   ELSE GENOP(ZERO);                                                                
01041600   GENOP(RETN);                                                                     
01041700 END;   %OF STRUCTFILEIOLIST                                                        
01041800                                                                                    
01041900                                                                                    
01042000                                                                                    
01042100   IF (READSTATEMENT OR READLN) THEN BEGIN                                          
01042200     GENV(NAMC,1,INTRINSICADDR(PASCALREADADDR,                                      
01042300       PASCALINTRINSIC(PASCALREADINTR)));                                           
01042400   END ELSE BEGIN                                                                   
01042500     GENV(NAMC,1,INTRINSICADDR(PASCALWRITEADDR,                                     
01042600       PASCALINTRINSIC(PASCALWRITEINTR)));                                          
01042700   END;                                                                             
01042800   GENOP(EXCH);                                                                     
01042900   GENV(NAMC,FILELEV,FILEADDR+1);  GENOP(LOAD);                                     
01043000   GENV(NAMC,FILELEV,FILEADDR+2);  GENOP(LOAD);                                     
01043100   LAB := MAKELABEL;                                                                
01043200   GENBR(BRUN,LAB);                                                                 
01043300   STRUCTFILEIOLIST(LCPCW);                                                         
01043400   GENLABEL(LAB);                                                                   
01043500   GENV(NAMC,LEXLEVEL,LCPCW);                                                       
01043600   GENOP(STFF);                                                                     
01043700   IF (READSTATEMENT OR READLN) THEN BEGIN                                          
01043800     FLAG := IF ASCIITOG THEN TRUE ELSE FALSE                                       
01043900             &IF READFUNCTION THEN FALSE ELSE TRUE [1:1]                            
01044000             ;                                                                      
01044100     GENLIT(REAL(FLAG));                                                            
01044200   END;                                                                             
01044300   GENOP(ENTR);                                                                     
01044400   IF (READSTATEMENT OR READLN) THEN BEGIN                                          
01044500     IF READFUNCTION THEN BEGIN                                                     
01044600       GTYPTR := INTPTR;                                                            
01044700     END ELSE BEGIN                                                                 
01044800       GENOP(DLET);                                                                 
01044900     END;                                                                           
01045000   END;                                                                             
01045100 END;   %OF STRUCTFILEIO                                                            
01045200                                                                                    
01045300 %-----------------------------------------------------------------------           
01045400                                                                                    
01045500 % COMMON PROCEDURES FOR GET/PUT AND READ/WRITE ON TEXT AND SIMPLE FILES            
01045600 %                                                                                  
01045700                                                                                    
01045800 %------------------------------------------------------------------                
01045900                                                                                    
01046000 PROCEDURE GENTEXTIOCALL(FCP);                                                      
01046100 %         *************                                                            
01046200 VALUE FCP;                                                                         
01046300 TYPESTRUCTPTR FCP;                                                                 
01046400 BEGIN                                                                              
01046500   GENOP(MKST);                                                                     
01046600   IF(READSTATEMENT OR READLN OR GET) THEN BEGIN                                    
01046700     GENV(NAMC,1,INTRINSICADDR(PASCALTEXTREADADDR,                                  
01046800           PASCALINTRINSIC(PASCALTEXTREADINTR)));                                   
01046900   END ELSE BEGIN                                                                   
01047000     GENV(NAMC,1,INTRINSICADDR(PASCALTEXTWRITEADDR,                                 
01047100         PASCALINTRINSIC(PASCALTEXTWRITEINTR)));                                    
01047200   END;                                                                             
01047300   GENV(NAMC,FILELEV,FILEADDR);                                                     
01047400   IF(VKIND(FCP)=FORMAL) THEN GENOP(LOAD)                                           
01047500                         ELSE GENOP(STFF);                                          
01047600   GENV(NAMC,FILELEV,FILEADDR+1); GENOP(LOAD);                                      
01047700   GENV(NAMC,FILELEV,FILEADDR+2); GENOP(LOAD);                                      
01047800 END;   %OF GENTEXTIOCALL                                                           
01047900                                                                                    
01048000 PROCEDURE GENFLAGS(FTYPTR,FCP,FRADIX);                                             
01048100 %         ********                                                                 
01048200 VALUE FTYPTR,FCP,FRADIX;                                                           
01048300 TYPEIDENTPTR FCP;                                                                  
01048400 TYPESTRUCTPTR FTYPTR;                                                              
01048500 BOOLEAN FRADIX;                                                                    
01048600 BEGIN                                                                              
01048700 TYPESTRUCTPTR LTYPTR;                                                              
01048800 REAL FLAG;                                                                         
01048900                                                                                    
01049000   LTYPTR := IF (FTYPTR=NIL) THEN FTYPTR                                            
01049100             ELSE IF (FORM(FTYPTR)=SUBRANGE) THEN RANGETYPE(FTYPTR)                 
01049200                  ELSE FTYPTR;                                                      
01049300   FLAG:=IF FRADIX THEN 5                                                           
01049400         ELSE IF(LTYPTR=CHARPTR) THEN 0                                             
01049500              ELSE IF(LTYPTR=INTPTR) THEN 1                                         
01049600                   ELSE IF(LTYPTR=REALPTR) THEN 2                                   
01049700                        ELSE IF(LTYPTR=BOOLPTR) THEN 4                              
01049800                             ELSE IF(LTYPTR=NIL) THEN 7                             
01049900                                  ELSE IF(FORM(LTYPTR)=SCALAR) THEN 6               
01050000                                       ELSE IF STRING(LTYPTR) THEN 8                
01050100                                            ELSE 7;                                 
01050200   IF GPACKEDSUBRFIELD THEN BEGIN                                                   
01050300     FLAG.[9:6] := GBITADDR;                                                        
01050400     FLAG.[15:6] := GBITRANGE;                                                      
01050500     FLAG.[41:1]:=REAL(TRUE);                                                       
01050600   END;                                                                             
01050700   IF (((READLN OR WRITELN) AND SYMBOLIN(SEMICOLONENDELSEUNTILSET OR                
01050800     RPARENTSET)) OR PUT) THEN BEGIN                                                
01050900     FLAG.[47:1]:=REAL(TRUE);                                                       
01051000   END;                                                                             
01051100   IF STRIPBLANKSTOG THEN BEGIN                                                     
01051200     FLAG.[46:1] := REAL(TRUE);                                                     
01051300   END;                                                                             
01051400   IF READFUNCTION THEN BEGIN                                                       
01051500     FLAG.[45:1] := REAL(TRUE);                                                     
01051600   END;                                                                             
01051700   IF (FILTYPE(IDTYPE(FCP))=WORDBUFPTR) THEN BEGIN                                  
01051800     FLAG.[44:1] := REAL(TRUE);                                                     
01051900   END;                                                                             
01052000   IF ASCIITOG THEN BEGIN                                                           
01052100     FLAG.[43:1]:=REAL(TRUE);                                                       
01052200   END;                                                                             
01052300   IF (FORM(FTYPTR)=SUBRANGE) THEN BEGIN                                            
01052400     IF BOUNDSCHECKTOG THEN BEGIN                                                   
01052500       FLAG.[42:1] := REAL(TRUE);                                                   
01052600     END;                                                                           
01052700   END;                                                                             
01052800   IF (LTYPTR=CHARPTR) THEN BEGIN                                                   
01052900     IF GPACKEDARRAY THEN BEGIN                                                     
01053000       FLAG.[40:1] := REAL(TRUE);                                                   
01053100     END;                                                                           
01053200   END;                                                                             
01053300   GENLIT(FLAG);                                                                    
01053400 END;   %OF GENFLAGS                                                                
01053500                                                                                    
01053600 %-----------------------------------------------------------------------           
01053700                                                                                    
01053800 % THIS SECTION HANDLES READ AND WRITE ON TEXT FILES AND ON SIMPLE                  
01053900 % FILES EG. FILE OF INTEGER.....                                                   
01054000                                                                                    
01054100 %------------------------------------------------------------------                
01054200                                                                                    
01054300 PROCEDURE READWRITETEXT(FCP,TEXTF);                                                
01054400 %         *************                                                            
01054500 VALUE FCP,TEXTF;                                                                   
01054600 TYPEIDENTPTR FCP;                                                                  
01054700 BOOLEAN TEXTF;                                                                     
01054800 BEGIN                                                                              
01054900 DEFINE                                                                             
01055000   SIMPLEVAR(GTYPTR) = (GTYPTR=REALPTR OR GTYPTR=INTPTR                             
01055100                        OR GTYPTR=BOOLPTR OR GTYPTR=CHARPTR)#,                      
01055200   DEFAULTW = 0 & 1[47:1]#,                                                         
01055300   DEFAULTD = 0 & 1[47:1]#;                                                         
01055400 BOOLEAN                                                                            
01055500   RADIXTYPE,                                                                       
01055600   IOLIST;                                                                          
01055700 TYPEIDENTPTR                                                                       
01055800   LCP;                                                                             
01055900 TYPESTRUCTPTR                                                                      
01056000   EXPRTYPE;                                                                        
01056100 INTEGER                                                                            
01056200   ENDLAB;                                                                          
01056300                                                                                    
01056400 IOLIST:=FALSE;                                                                     
01056500 IF READSTATEMENT OR READLN THEN BEGIN                                              
01056600   WHILE (SYMBOL=IDENT) DO BEGIN                                                    
01056700     PRTERR:=FALSE;                                                                 
01056800     SEARCHID(KONSTVARFLDFNCSET,LCP);                                               
01056900     PRTERR:=TRUE;                                                                  
01057000     IF(VFORCONTRL(LCP)=REAL(TRUE)) THEN BEGIN                                      
01057100       ERROR(2940);                                                                 
01057200     END;                                                                           
01057300     GENTEXTIOCALL(FCP);                                                            
01057400     EXPRESSION(FSYS OR COMMARPARENTSET);                                           
01057500     IF (GACCESS=DRCT) THEN BEGIN                                                   
01057600       LOADIRW;                                                                     
01057700       IF NOT TRUSTWORTHYTOG THEN BEGIN                                             
01057800         GENOP(DUPL);     %ZAP THE TAG 6 TO PREVENT AN                              
01057900         GENOP(ZERO);     %INV OPERATOR ABORT IN THE INTRINSIC                      
01058000         GENOP(STOD);     %AS IT USES AN EVAL OPERATOR                              
01058100       END;                                                                         
01058200     END ELSE BEGIN                                                                 
01058300       LOADINXDDESCRIPTOR;                                                          
01058400     END;                                                                           
01058500     IF NOT TEXTF THEN BEGIN                                                        
01058600       IF NOT ASSCOMPTYPES(GTYPTR,ORIGFILTYPE(IDTYPE(FCP))) THEN BEGIN              
01058700         ERROR(2941);                                                               
01058800       END;                                                                         
01058900     END;                                                                           
01059000     GENOP(DUPL);                                                                   
01059100     IF (FORM(GTYPTR)=SUBRANGE) THEN BEGIN                                          
01059200       GENLIT(SMIN(GTYPTR));                                                        
01059300       GENLIT(SMAX(GTYPTR));                                                        
01059400     END ELSE BEGIN                                                                 
01059500       IF STRING(GTYPTR) THEN BEGIN                                                 
01059600         GENLIT(SWORDS(GTYPTR));                                                    
01059700         IF STANDARDTOG THEN ERROR(1946);                                           
01059800       END ELSE BEGIN                                                               
01059900         GENOP(ZERO);                                                               
01060000       END;                                                                         
01060100       GENOP(ZERO);                                                                 
01060200     END;                                                                           
01060300     IF (FORM(GTYPTR)=SCALAR) AND (NOT SIMPLEVAR(GTYPTR)) THEN BEGIN                
01060400       IF NOT BOOLEAN(SIO(GTYPTR)) THEN BEGIN                                       
01060500         CREATED1RECORD(GTYPTR);                                                    
01060600       END;                                                                         
01060700       GENOP(ZERO);                                                                 
01060800       GENV(NAMC,1,SD1DISP(GTYPTR));                                                
01060900       GENOP(INDX);                                                                 
01061000       GENOP1(BSET,42);                                                             
01061100       IF STANDARDTOG THEN ERROR(1945);                                             
01061200     END ELSE BEGIN                                                                 
01061300       GENOP(ZERO);                                                                 
01061400     END;                                                                           
01061500     GENFLAGS(GTYPTR,FCP,FALSE);                                                    
01061600     IF NOT IOLIST THEN BEGIN                                                       
01061700       IOLIST:=TRUE;                                                                
01061800       IF READFUNCTION THEN BEGIN                                                   
01061900         ENDLAB:=MAKELABEL;                                                         
01062000       END;                                                                         
01062100     END;                                                                           
01062200     GENOP(ENTR);                                                                   
01062300     IF NOT(SIMPLEVAR(GTYPTR) OR STRING(GTYPTR) OR                                  
01062400       FORM(GTYPTR)=SUBRANGE OR FORM(GTYPTR)=SCALAR) THEN                           
01062500         ERROR(2948);                                                               
01062600     IF (SYMBOL=COMMA) THEN BEGIN                                                   
01062700       INSYMBOL;                                                                    
01062800       IF READFUNCTION THEN BEGIN                                                   
01062900         GENOP(DUPL);                                                               
01063000         GENOP(ZERO);                                                               
01063100         GENOP(EQUL);                                                               
01063200         GENBR(BRFL,ENDLAB);                                                        
01063300       END;                                                                         
01063400       GENOP(DLET);                                                                 
01063500     END ELSE BEGIN                                                                 
01063600       IF READFUNCTION THEN BEGIN                                                   
01063700         GENLABEL(ENDLAB);                                                          
01063800       END;                                                                         
01063900     END;                                                                           
01064000   END;   %OF WHILE                                                                 
01064100   IF NOT IOLIST THEN BEGIN                                                         
01064200     IF READLN THEN BEGIN                                                           
01064300       GENTEXTIOCALL(FCP);                                                          
01064400       GENOP(ZERO);                                                                 
01064500       GENOP(DUPL);                                                                 
01064600       GENOP(DUPL);                                                                 
01064700       GENOP(DUPL);                                                                 
01064800       GENOP(DUPL);                                                                 
01064900       GENFLAGS(NIL,FCP,FALSE);                                                     
01065000       GENOP(ENTR);                                                                 
01065100     END;                                                                           
01065200   END;                                                                             
01065300   IF READFUNCTION THEN BEGIN                                                       
01065400     GTYPTR:=INTPTR;                                                                
01065500   END ELSE BEGIN                                                                   
01065600     GENOP(DLET);                                                                   
01065700   END;                                                                             
01065800 END ELSE BEGIN                                                                     
01065900   WHILE (SYMBOLIN(SIMPTYPEBEGSYS) OR (SYMBOL=NOTSY)) DO BEGIN                      
01066000     GENTEXTIOCALL(FCP);                                                            
01066100     RADIXTYPE:=FALSE;                                                              
01066200     EXPRESSION(FSYS OR COMMACOLONRPARENTSET);                                      
01066300     EXPRTYPE:=GTYPTR;                                                              
01066400     IF NOT TEXTF THEN BEGIN                                                        
01066500       IF NOT ASSCOMPTYPES(ORIGFILTYPE(IDTYPE(FCP)),EXPRTYPE) THEN BEGIN            
01066600         ERROR(2941);                                                               
01066700       END;                                                                         
01066800     END;                                                                           
01066900     IF STRING(GTYPTR) THEN BEGIN                                                   
01067000       IF (GVLEVEL=1) THEN BEGIN                                                    
01067100         GENLIT(GIDPLMT);                                                           
01067200         GENV(NAMC,GVLEVEL,GDPLMT);                                                 
01067300       END ELSE BEGIN                                                               
01067400         LOADIRW;                                                                   
01067500       END;                                                                         
01067600       GENOP(INDX);                                                                 
01067700     END ELSE BEGIN                                                                 
01067800       IF ((GACCESS=DRCT) OR (GKIND=CST) OR (GCHARSIZE=1) OR                        
01067900           GPACKEDSUBRFIELD OR GPACKEDARRAY) THEN BEGIN                             
01068000         LOADV;                                                                     
01068100       END ELSE BEGIN                                                               
01068200         LOADIRW;                                                                   
01068300         IF (FORM(GTYPTR)>POWER) THEN BEGIN                                         
01068400           IF(GKIND=VARBL) THEN BEGIN                                               
01068500             GENOP(INDX);                                                           
01068600           END;                                                                     
01068700         END;                                                                       
01068800       END;                                                                         
01068900     END;                                                                           
01069000     GENOP(DUPL);                                                                   
01069100     IF SYMBOLIN(COMMARPARENTSET) THEN BEGIN                                        
01069200       GENLIT(DEFAULTW);                                                            
01069300       IF STRING(GTYPTR) THEN BEGIN                                                 
01069400         GENLIT(SWORDS(GTYPTR));                                                    
01069500       END ELSE BEGIN                                                               
01069600         GENLIT(DEFAULTD);                                                          
01069700       END;                                                                         
01069800     END ELSE BEGIN                                                                 
01069900       IF (SYMBOL=COLON) THEN BEGIN                                                 
01070000         INSYMBOL;                                                                  
01070100         IF (SYMBOL=COLON) THEN BEGIN                                               
01070200           IF (SIMPLEVAR(EXPRTYPE) OR FORM(EXPRTYPE)<=SUBRANGE OR                   
01070300           SHORTSET(EXPRTYPE)) THEN BEGIN                                           
01070400             RADIXTYPE:=TRUE;                                                       
01070500             IF STANDARDTOG THEN ERROR(1948);                                       
01070600           END ELSE BEGIN                                                           
01070700             ERROR(2942);                                                           
01070800           END;                                                                     
01070900           INSYMBOL;                                                                
01071000         END;                                                                       
01071100         IF SYMBOLIN(SIMPTYPEBEGSYS) THEN BEGIN                                     
01071200           EXPRESSION(FSYS OR COMMACOLONRPARENTSET);                                
01071300           LOADV;                                                                   
01071400         END ELSE BEGIN                                                             
01071500           ERROR(2943);                                                             
01071600         END;                                                                       
01071700         IF (SYMBOL=COLON) THEN BEGIN                                               
01071800           INSYMBOL;                                                                
01071900           IF NOT (RADIXTYPE OR (EXPRTYPE=REALPTR))                                 
01072000           THEN BEGIN                                                               
01072100             ERROR(2944);                                                           
01072200           END;                                                                     
01072300           IF SYMBOLIN(SIMPTYPEBEGSYS) THEN BEGIN                                   
01072400             EXPRESSION(FSYS OR COMMARPARENTSET);                                   
01072500             LOADV;                                                                 
01072600           END ELSE BEGIN                                                           
01072700             ERROR(2943);                                                           
01072800           END;                                                                     
01072900         END ELSE BEGIN                                                             
01073000           IF STRING(EXPRTYPE) THEN BEGIN                                           
01073100             GENLIT(SWORDS(EXPRTYPE));                                              
01073200           END ELSE BEGIN                                                           
01073300             GENLIT(DEFAULTD);                                                      
01073400           END;                                                                     
01073500         END;                                                                       
01073600       END ELSE BEGIN                                                               
01073700         GENLIT(DEFAULTW);                                                          
01073800         IF STRING(EXPRTYPE) THEN BEGIN                                             
01073900           GENLIT(SWORDS(EXPRTYPE));                                                
01074000         END ELSE BEGIN                                                             
01074100           GENLIT(DEFAULTD);                                                        
01074200         END;                                                                       
01074300       END;                                                                         
01074400     END;                                                                           
01074500     IF (FORM(EXPRTYPE)=SCALAR) AND (NOT SIMPLEVAR(EXPRTYPE)) THEN BEGIN            
01074600       IF NOT BOOLEAN(SIO(EXPRTYPE)) THEN BEGIN                                     
01074700         CREATED1RECORD(EXPRTYPE);                                                  
01074800       END;                                                                         
01074900       GENOP(ZERO);                                                                 
01075000       GENV(NAMC,1,SD1DISP(EXPRTYPE));                                              
01075100       GENOP(INDX);                                                                 
01075200       GENOP1(BSET,42);                                                             
01075300       IF STANDARDTOG THEN ERROR(1947);                                             
01075400     END ELSE BEGIN                                                                 
01075500       GENOP(ZERO);                                                                 
01075600     END;                                                                           
01075700     GENFLAGS(EXPRTYPE,FCP,RADIXTYPE);                                              
01075800     GENOP(ENTR);                                                                   
01075900     IF NOT(SIMPLEVAR(GTYPTR) OR STRING(GTYPTR) OR                                  
01076000       FORM(GTYPTR)=SUBRANGE OR FORM(GTYPTR)=SCALAR) THEN                           
01076100         ERROR(2948);                                                               
01076200     IF (SYMBOL=COMMA) THEN BEGIN                                                   
01076300       INSYMBOL;                                                                    
01076400     END;                                                                           
01076500     IOLIST:=TRUE;                                                                  
01076600   END;    %OF WHILE                                                                
01076700   IF NOT IOLIST THEN BEGIN                                                         
01076800     IF WRITELN THEN BEGIN                                                          
01076900       GENTEXTIOCALL(FCP);                                                          
01077000       GENOP(ZERO);                                                                 
01077100       GENOP(DUPL);                                                                 
01077200       GENOP(DUPL);                                                                 
01077300       GENOP(DUPL);                                                                 
01077400       GENOP(DUPL);                                                                 
01077500       GENFLAGS(NIL,FCP,FALSE);                                                     
01077600       GENOP(ENTR);                                                                 
01077700     END;                                                                           
01077800   END;                                                                             
01077900 END;                                                                               
01078000 END;   %OF READWRITETEXT                                                           
01078100                                                                                    
01078200 %-=-------------------------------------------------------------------             
01078300                                                                                    
01078400 % THIS SECTION HANDLES GET/PUT ON TEXT FILES OR SIMPLE FILES                       
01078500 % EG. FILE OF REAL, .....                                                          
01078600                                                                                    
01078700 %-----------------------------------------------------------------------           
01078800                                                                                    
01078900 PROCEDURE GETPUTIOCALL;                                                            
01079000 %         ************                                                             
01079100 BEGIN                                                                              
01079200   INTEGER I;                                                                       
01079300   GENTEXTIOCALL(LCP);                                                              
01079400   IF SIMPLECOMP THEN BEGIN                                                         
01079500     GENOP1(LT8,2);  GENV(VALC,FILELEV,FILEADDR+2);                                 
01079600     GENOP(ONE);  GENOP(SUBT);                                                      
01079700     GENV(VALC,FILELEV,FILEADDR+1);                                                 
01079800     GENOP(ZERO);                                                                   
01079900   END ELSE BEGIN                                                                   
01080000     GENOP(ZERO);                                                                   
01080100     GENOP(DUPL);                                                                   
01080200   END;                                                                             
01080300   FOR I:=1 STEP 1 UNTIL 3 DO GENOP(DUPL);                                          
01080400   GENFLAGS(NIL,LCP,FALSE);                                                         
01080500   GENOP(ENTR);                                                                     
01080600   IF GET THEN GENOP(DLET);                                                         
01080700 END;   %OF GETPUTIOCALL                                                            
01080800                                                                                    
01080900 PROCEDURE PROCESSTEXTGETPUT;                                                       
01081000 %         *****************                                                        
01081100 BEGIN                                                                              
01081200 INTEGER                                                                            
01081300   LABEOL,                                                                          
01081400   LABEXIT;                                                                         
01081500   GENOP1(LT8,6);                                                                   
01081600   GENV(NAMC,FILELEV,FILEADDR+2);                                                   
01081700   GENOP(INDX);                                                                     
01081800   LABEOL:=MAKELABEL;                                                               
01081900   GENBR(STBR,LABEOL);                                                              
01082000   LABEXIT:=MAKELABEL;                                                              
01082100   GENBR(BRTR,LABEXIT);                                                             
01082200   GENOP(NVLD);     %SHOULD NEVER OCCUR                                             
01082300   GENLABEL(LABEOL);                                                                
01082400   GETPUTIOCALL;                                                                    
01082500   GENLABEL(LABEXIT);                                                               
01082600 END;   % OF PROCESSTEXTGETPUT                                                      
01082700                                                                                    
01082800 PROCEDURE PROCESSSIMPLGETPUT;                                                      
01082900 %         ******************                                                       
01083000 BEGIN                                                                              
01083100 INTEGER                                                                            
01083200   LABEOL,                                                                          
01083300   LABEXIT;                                                                         
01083400   GENOP1(LT8,3);                                                                   
01083500   GENV(VALC,FILELEV,FILEADDR+2);                                                   
01083600   GENOP1(LT8,2);   GENV(VALC,FILELEV,FILEADDR+2);                                  
01083700   GENOP(ONE);  GENOP(SUBT);                                                        
01083800   GENOP(GREQ);                                                                     
01083900   LABEOL:=MAKELABEL;                                                               
01084000   GENBR(BRTR,LABEOL);                                                              
01084100   GENOP1(LT8,3);                                                                   
01084200   GENV(NAMC,FILELEV,FILEADDR+2);                                                   
01084300   GENOP(INDX);                                                                     
01084400   GENOP1(LT8,3);                                                                   
01084500   GENV(VALC,FILELEV,FILEADDR+2);                                                   
01084600   GENOP(ONE);                                                                      
01084700   GENOP(ADD);                                                                      
01084800   GENOP(STOD);                                                                     
01084900   LABEXIT:=MAKELABEL;                                                              
01085000   GENBR(BRUN,LABEXIT);                                                             
01085100   GENLABEL(LABEOL);                                                                
01085200   GETPUTIOCALL;                                                                    
01085300   GENLABEL(LABEXIT);                                                               
01085400 END;   %OF PROCESSSIMPLGETPUT                                                      
01085500                                                                                    
01085600                                                                                    
01085700 %-----------------------------------------------------------------------           
01085800                                                                                    
01085900 %***********************************************************************           
01086000 %*   MAIN SECTION OF STREAM I/O                                                    
01086100 %***********************************************************************           
01086200                                                                                    
01086300                                                                                    
01086400 SIMPLECOMP:=FALSE;                                                                 
01086500 IF (SYMBOL = IDENT) THEN BEGIN                                                     
01086600   SEARCHID(KONSTVARFLDFNCSET OR PRCSET,LCP);                                       
01086700   IF (KLASS(LCP) NEQ NIL) THEN BEGIN                                               
01086800     IF (FORM(IDTYPE(LCP)) = FILES) THEN BEGIN                                      
01086900       FILELEV := VLEV(LCP); FILEADDR := VADDR(LCP);                                
01087000       TEXTF:= TEXTFILE(IDTYPE(LCP)) = TEXTFIL;                                     
01087100       SIMPLECOMP:=FILTYPE(IDTYPE(LCP))=WORDBUFPTR;                                 
01087200       INSYMBOL;                                                                    
01087300       IF(NOT GETPUT) THEN BEGIN                                                    
01087400         IF(SYMBOL=COMMA) THEN BEGIN                                                
01087500           INSYMBOL;                                                                
01087600         END ELSE BEGIN                                                             
01087700           IF(SYMBOL = ARROW) THEN BEGIN                                            
01087800             ERROR(2907);                                                           
01087900             FILELEV := BASELVL;                                                    
01088000             FILEADDR := ADDROFILE;   %CAN ONLY OCCUR FOR OUTPUT                    
01088100             SKIP(COMMARPARENTSET);                                                 
01088200             IF(SYMBOL = COMMA) THEN INSYMBOL;                                      
01088300           END ELSE BEGIN                                                           
01088400             IF NOT(SYMBOL=RPARENT) THEN ERROR(2903);                               
01088500           END;                                                                     
01088600         END;                                                                       
01088700       END;                                                                         
01088800     END ELSE BEGIN                                                                 
01088900       FILELEV := BASELVL;                                                          
01089000       FILEADDR:= IF(READSTATEMENT OR READLN) THEN ADDRIFILE                        
01089100                  ELSE ADDROFILE;                                                   
01089200       TEXTF:=TRUE;                                                                 
01089300       LCP:=NIL;                                                                    
01089400     END;                                                                           
01089500   END ELSE BEGIN                                                                   
01089600     FILELEV := BASELVL;                                                            
01089700     FILEADDR:= IF(READSTATEMENT OR READLN) THEN ADDRIFILE                          
01089800                ELSE ADDROFILE;                                                     
01089900     TEXTF:=TRUE;                                                                   
01090000     LCP:=NIL;                                                                      
01090100   END;                                                                             
01090200 END ELSE BEGIN                                                                     
01090300   FILELEV := BASELVL;                                                              
01090400   FILEADDR:= IF(READSTATEMENT OR READLN) THEN ADDRIFILE                            
01090500              ELSE ADDROFILE;                                                       
01090600   TEXTF:=TRUE;                                                                     
01090700   LCP:=NIL;                                                                        
01090800 END;                                                                               
01090900 IF TEXTF THEN BEGIN                                                                
01091000   IF GETPUT THEN BEGIN                                                             
01091100     PROCESSTEXTGETPUT;                                                             
01091200   END ELSE BEGIN                                                                   
01091300     READWRITETEXT(LCP,TEXTF);                                                      
01091400   END;                                                                             
01091500 END ELSE BEGIN                                                                     
01091600   IF SIMPLECOMP THEN BEGIN                                                         
01091700     IF GETPUT THEN BEGIN                                                           
01091800       PROCESSSIMPLGETPUT;                                                          
01091900     END ELSE BEGIN                                                                 
01092000       READWRITETEXT(LCP,TEXTF);                                                    
01092100     END;                                                                           
01092200   END ELSE BEGIN                                                                   
01092300     GENOP(MKST);                                                                   
01092400     GENV(NAMC,FILELEV,FILEADDR);                                                   
01092500     IF(LCP =NIL) THEN BEGIN                                                        
01092600       GENOP(STFF);                                                                 
01092700     END ELSE BEGIN                                                                 
01092800       IF (FORM(IDTYPE(LCP))=FILES) THEN BEGIN                                      
01092900         IF (VKIND(LCP)=FORMAL) THEN BEGIN                                          
01093000           GENOP(LOAD);                                                             
01093100         END ELSE BEGIN                                                             
01093200           GENOP(STFF);                                                             
01093300         END;                                                                       
01093400       END ELSE BEGIN                                                               
01093500         GENOP(STFF);                                                               
01093600       END;                                                                         
01093700     END;                                                                           
01093800     STRUCTFILEIO;                                                                  
01093900   END;                                                                             
01094000 END;                                                                               
01094100 END;   % OF STREAMIO                                                               
01094200                                                                                    
01094300                                                                                    
01094400 %-----------------------------------------------------------------------           
01094500                                                                                    
01094600 % THIS SECTION HANDLES FORMATTED I/O USING READREC AND                             
01094700 % WRITEREC AND BURROUGHS INTRINSICS.                                               
01094800 % BURROUGHS FREE FORMAT I/O ALLOWED.                                               
01094900 % GET, PUT ON STRUCTURED FILES, SEEK, SPACE ALSO HANDLED HERE.                     
01095000                                                                                    
01095100 %---------------------------------------------------------------------             
01095200                                                                                    
01095300 PROCEDURE READRECWRITEREC(LKEY);                                                   
01095400 %         ***************                                                          
01095500 VALUE LKEY; INTEGER LKEY;                                                          
01095600 BEGIN                                                                              
01095700 DEFINE                                                                             
01095800   NOUNITFEATURE = 3#,                                                              
01095900   STOPUNITFEATURE = 8#,                                                            
01096000   NOTKEYED = (UNITFEATURE=0 AND KEYED=0)#,                                         
01096100   IOERR = 46#,                                                                     
01096200   FORTALGFORMATTEDIN = 142#,                                                       
01096300   FORTALGFORMATTEDOUT = 095#,                                                      
01096400   FORTALGFREEFIELDIN = 144#,                                                       
01096500   FORTALGFREEFIELDOUT = 143#,                                                      
01096600   FREEFIELDSYMBOL = (SYMBOL = MULOP) AND (OP = REALDIV)#,                          
01096700   LANGUAGENO = 0#,            % = ALGOL                                            
01096800   NO = 4"03""NO" FOR 3#,                                                           
01096900   STOP = 4"05""STOP" FOR 5#,                                                       
01097000   READREC = (LKEY = 22)#,                                                          
01097100   WRITEREC = (LKEY = 23)#,                                                         
01097200   SEEKSTATEMENT = (LKEY = 11)#,                                                    
01097300   SPACESTATEMENT = (LKEY = 12)#,                                                   
01097400   SEEKSPACE = (SEEKSTATEMENT OR SPACESTATEMENT)#,                                  
01097500   GET = (LKEY=1)#,                                                                 
01097600   PUT = (LKEY=2)#,                                                                 
01097700   GETPUT = (GET OR PUT)#,                                                          
01097800   ARRAYSIZE = (SWORDS(FILTYPE(IDTYPE(LCP))))#;                                     
01097900 INTEGER                                                                            
01098000   KEYED,                                                                           
01098100   LCPCW,                                                                           
01098200   LCP;                                                                             
01098300 BOOLEAN                                                                            
01098400   FREEFIELD;                                                                       
01098500 INTEGER                                                                            
01098600   FILELEV,                                                                         
01098700   FILEADDR,                                                                        
01098800   LAB,                                                                             
01098900   UNITFEATURE;                                                                     
01099000 REAL                                                                               
01099100   CHOOSEWORD;                                                                      
01099200 LABEL                                                                              
01099300   AWAY;                                                                            
01099400                                                                                    
01099500 DEFINE CHECKBRACKETEDOPS = BEGIN                                                   
01099600   UNITFEATURE := 0;                                                                
01099700   IF (SYMBOL = LBRACK) OR ((SEEKSPACE OR GETPUT) AND SYMBOL=COMMA)                 
01099800   THEN BEGIN                                                                       
01099900     INSYMBOL;                                                                      
01100000     IF (SYMBOL = IDENT) THEN BEGIN                                                 
01100100       IF (NAMEBUF0 = NO) THEN BEGIN                                                
01100200         GENOP(ZERO);                                                               
01100300         UNITFEATURE := NOUNITFEATURE;                                              
01100400         INSYMBOL;                                                                  
01100500       END ELSE BEGIN                                                               
01100600         IF (NAMEBUF0 = STOP) THEN BEGIN                                            
01100700           GENOP(ZERO);                                                             
01100800           UNITFEATURE := STOPUNITFEATURE;                                          
01100900           INSYMBOL;                                                                
01101000         END ELSE BEGIN                                                             
01101100           EXPRESSION(FSYS OR RBRACKSET OR RPARENTSET);                             
01101200           LOADV;                                                                   
01101300           IF NOT SPACESTATEMENT THEN KEYED := 2;                                   
01101400         END;                                                                       
01101500       END;                                                                         
01101600     END ELSE BEGIN                                                                 
01101700       IF SYMBOLIN(CONSTBEGSYS) THEN BEGIN                                          
01101800         EXPRESSION(FSYS OR RBRACKSET OR RPARENTSET);                               
01101900         LOADV;                                                                     
01102000         IF NOT SPACESTATEMENT THEN KEYED := 2;                                     
01102100       END ELSE BEGIN                                                               
01102200         ERROR(2900);          %INVALID ACTION                                      
01102300         INSYMBOL;                                                                  
01102400       END;                                                                         
01102500     END;                                                                           
01102600     IF COMPTYPES(GTYPTR,INTPTR) THEN GENOP(NTGR);                                  
01102700     IF (SYMBOL = RBRACK) THEN INSYMBOL                                             
01102800     ELSE IF NOT (SEEKSPACE OR GETPUT) THEN BEGIN                                   
01102900       ERROR(2901);                                                                 
01103000       SKIP (COMMASEMICOLONRPARENTSET OR RBRACKSET);                                
01103100     END;                                                                           
01103200     IF(SYMBOL = COMMA) THEN INSYMBOL                                               
01103300     ELSE IF (SYMBOL NEQ RPARENT) THEN ERROR(2902);                                 
01103400   END ELSE BEGIN                                                                   
01103500     IF (GETPUT) THEN GENOP(ZERO);                                                  
01103600     IF SEEKSPACE THEN ERROR(2906);                                                 
01103700   END;                                                                             
01103800 END#,                                                                              
01103900                                                                                    
01104000 FORMCHOOSEWORD = BEGIN                                                             
01104100   CHOOSEWORD := 0                                                                  
01104200                & (IF SPACESTATEMENT THEN 0 ELSE 1) [43:1]                          
01104300                & 7 [35:3]     %RETURNS STATUS WORD                                 
01104400                & LANGUAGENO [19:8]                                                 
01104500                & IF SEEKSPACE THEN 4 ELSE                                          
01104600                  IF (UNITFEATURE = NOUNITFEATURE) THEN 3 ELSE                      
01104700                  (KEYED+(IF (READREC OR GET) THEN 1 ELSE 0))[11:4]                 
01104800                & 1 [7:1]  %ALL I/O BEFORE UNITFEATURE                              
01104900 % THE FOLLOWING LINE IS NEEDED TO IMPLEMENT WRITE AFTER C-C ACTION                 
01105000 %              & (IF (SEEKSPACE OR GETPUT) THEN 1 ELSE 0) [7:1]                    
01105100                & (IF SEEKSTATEMENT THEN 1 ELSE                                     
01105200                   IF SPACESTATEMENT THEN 2 ELSE                                    
01105300                   UNITFEATURE) [6:6]                                               
01105400                & (IF(KEYED>0) THEN 1 ELSE 0)[0:1]                                  
01105500                ;                                                                   
01105600   END#;                                                                            
01105700                                                                                    
01105800 PROCEDURE FREEFIELDIO;                                                             
01105900 %         ===========                                                              
01106000 BEGIN                                                                              
01106100   FREEFIELD := TRUE;                                                               
01106200   IF READREC THEN BEGIN                                                            
01106300     GENV(NAMC,1,INTRINSICADDR(FREEFIELDINADDR,FORTALGFREEFIELDIN));                
01106400   END ELSE BEGIN                                                                   
01106500     GENV(NAMC,1,INTRINSICADDR(FREEFIELDOUTADDR,FORTALGFREEFIELDOUT));              
01106600   END;                                                                             
01106700   GENOP(RSDN);                                                                     
01106800   GENOP(ZERO); GENOP1(BSET,47);   %FREEFIELD DELIMITER = BLANK                     
01106900   GENOP(ZERO);                                                                     
01107000 END;   %OF FREEFIELDIO                                                             
01107100                                                                                    
01107200 PROCEDURE IOLIST(LCPCW);                                                           
01107300 %         ******                                                                   
01107400 INTEGER LCPCW;                                                                     
01107500 BEGIN                                                                              
01107600   INTEGER                                                                          
01107700     LABELA;                                                                        
01107800   REAL                                                                             
01107900     PCWPOSN;                                                                       
01108000   LEXLEVEL := *+1;             %FOR PCW WORD                                       
01108100   LABELA := MAKELABEL;                                                             
01108200   GENLABEL(LABELA);                                                                
01108300   PCWPOSN := ASKFORPCW(LABELA) & 0[47:1];                                          
01108400   LEXLEVEL := *-1;                                                                 
01108500   LISTPROC := TRUE;                                                                
01108600   LISTELEMENT := FALSE;                                                            
01108700   MAXFIELDSIZE :=0;                                                                
01108800   STATEMENT(STATBEGSYS OR CONSTBEGSYS OR SEMICOLONRPARENTSET);                     
01108900   IF (NOT LISTELEMENT) THEN ERROR (2910);                                          
01109000   IF NOT(SYMBOL = RPARENT) THEN BEGIN                                              
01109100     ERROR(2911); SKIP(SEMICOLONRPARENTSET);                                        
01109200   END;                                                                             
01109300   GENOP(EXIT);                                                                     
01109400   GENERATEPCWWORD(PCWPOSN,NIL);                                                    
01109500   LCPCW := LC;                                                                     
01109600   IF CODETOG THEN BEGIN                                                            
01109700     REPLACE LBUF0 BY                                                               
01109800       "(", LEXLEVEL FOR 2 DIGITS,                                                  
01109900       ",", LC FOR 5 DIGITS,                                                        
01110000       ") = I/O LIST PCW";                                                          
01110100     WRITELBUFFER;                                                                  
01110200   END;                                                                             
01110300   LC := LC+1;                                                                      
01110400   LISTPROC := FALSE;                                                               
01110500 END;  %OF IOLIST                                                                   
01110600                                                                                    
01110700                                                                                    
01110800 %***********************************************************************           
01110900 %   MAIN SECTION OF READREC/WRITEREC                                               
01111000 %***********************************************************************           
01111100                                                                                    
01111200 IF (SYMBOL = IDENT) THEN BEGIN                                                     
01111300   SEARCHID(KONSTVARFLDFNCPRCFMTSET,LCP);                                           
01111400   IF (KLASS(LCP) NEQ FORMATS) THEN BEGIN                                           
01111500     IF (FORM(IDTYPE(LCP)) = FILES) THEN BEGIN                                      
01111600       FILELEV := VLEV(LCP); FILEADDR := VADDR(LCP);                                
01111700       INSYMBOL;                                                                    
01111800       IF(NOT(SEEKSPACE OR GETPUT)) THEN BEGIN                                      
01111900         IF(SYMBOL=COMMA) THEN BEGIN                                                
01112000           INSYMBOL;                                                                
01112100         END ELSE BEGIN                                                             
01112200           IF(SYMBOL = ARROW) THEN BEGIN                                            
01112300             ERROR(2907);                                                           
01112400             FILELEV := BASELVL;                                                    
01112500             FILEADDR := ADDROFILE;   %CAN ONLY OCCUR FOR OUTPUT                    
01112600             SKIP(COMMARPARENTSET);                                                 
01112700             IF(SYMBOL = COMMA) THEN INSYMBOL;                                      
01112800           END ELSE BEGIN                                                           
01112900             IF NOT(SYMBOL=RPARENT OR SYMBOL=LBRACK) THEN ERROR(2903);              
01113000           END;                                                                     
01113100         END;                                                                       
01113200       END;                                                                         
01113300     END ELSE BEGIN                                                                 
01113400       FILELEV := BASELVL;                                                          
01113500       FILEADDR:= IF READREC THEN ADDRIFILE                                         
01113600                  ELSE ADDROFILE;                                                   
01113700     END;                                                                           
01113800   END ELSE BEGIN                                                                   
01113900     FILELEV := BASELVL;                                                            
01114000     FILEADDR:= IF READREC THEN ADDRIFILE                                           
01114100                ELSE ADDROFILE;                                                     
01114200   END;                                                                             
01114300 END ELSE BEGIN                                                                     
01114400   FILELEV := BASELVL;                                                              
01114500   FILEADDR:= IF READREC THEN ADDRIFILE                                             
01114600              ELSE ADDROFILE;                                                       
01114700 END;                                                                               
01114800 IF SEEKSPACE THEN BEGIN   %FLUSH BUFFER                                            
01114900   GENOP(MKST);                                                                     
01115000   GENV(NAMC,1,INTRINSICADDR(PASCALFLUSHFILEADDR,                                   
01115100               PASCALINTRINSIC(PASCALFLUSHBUFFERINTR)));                            
01115200   GENV(NAMC,FILELEV,FILEADDR);  GENOP(STFF);                                       
01115300   GENV(NAMC,FILELEV,FILEADDR+1); GENOP(LOAD);                                      
01115400   GENV(NAMC,FILELEV,FILEADDR+2); GENOP(LOAD);                                      
01115500   GENOP(ENTR);                                                                     
01115600 END;                                                                               
01115700 GENOP(MKST);                                                                       
01115800 IF (SEEKSPACE OR GETPUT) THEN GENOP(ZERO);                                         
01115900 GENV(NAMC,FILELEV,FILEADDR);                                                       
01116000 IF (SEEKSPACE OR GETPUT) THEN BEGIN                                                
01116100   IF SEEKSTATEMENT THEN KEYED := 1;                                                
01116200   GENOP(INDX);  GENOP(LOAD);                                                       
01116300   IF GETPUT AND((SYMBOL=LBRACK) OR (SYMBOL=COMMA)) THEN BEGIN                      
01116400     GENOP1(LT8,IF PUT THEN 2 ELSE 3);                                              
01116500     GENOP(LOR);                                                                    
01116600   END ELSE                                                                         
01116700   IF (NOT PUT) THEN BEGIN                                                          
01116800     IF (SEEKSPACE) THEN GENOP1(LT8,4)                                              
01116900                    ELSE GENOP(ONE);                                                
01117000     GENOP(LOR);                                                                    
01117100   END;                                                                             
01117200 END ELSE BEGIN                                                                     
01117300   IF(LCP =NIL) THEN BEGIN                                                          
01117400     GENOP(STFF);                                                                   
01117500   END ELSE BEGIN                                                                   
01117600     IF (FORM(IDTYPE(LCP))=FILES) THEN BEGIN                                        
01117700       IF (VKIND(LCP)=FORMAL) THEN BEGIN                                            
01117800         GENOP(LOAD);                                                               
01117900       END ELSE BEGIN                                                               
01118000         GENOP(STFF);                                                               
01118100       END;                                                                         
01118200     END ELSE BEGIN                                                                 
01118300       GENOP(STFF);                                                                 
01118400     END;                                                                           
01118500   END;                                                                             
01118600 END;                                                                               
01118700 CHECKBRACKETEDOPS;                                                                 
01118800 IF NOT (SEEKSPACE OR GETPUT) THEN BEGIN                                            
01118900   IF(SYMBOL = IDENT) THEN BEGIN                                                    
01119000     SEARCHID(KONSTVARFLDFNCPRCFMTSET,LCP);                                         
01119100     IF (KLASS(LCP) NEQ FORMATS) THEN BEGIN                                         
01119200       IF NOTKEYED THEN GENOP(ZERO);                                                
01119300       FREEFIELDIO;                                                                 
01119400     END ELSE BEGIN                                                                 
01119500       IF NOTKEYED THEN GENOP(ZERO);                                                
01119600       FREEFIELD := FALSE;                                                          
01119700       IF READREC THEN BEGIN                                                        
01119800         GENV(NAMC,1,INTRINSICADDR(FORMATTEDINADDR,FORTALGFORMATTEDIN));            
01119900       END ELSE BEGIN                                                               
01120000       GENV(NAMC,1,INTRINSICADDR(FORMATTEDOUTADDR,FORTALGFORMATTEDOUT));            
01120100       END;                                                                         
01120200       GENOP(RSDN);                                                                 
01120300       GENV(NAMC,VLEV(LCP),VADDR(LCP));                                             
01120400       GENOP(LOAD);                                                                 
01120500       GENOP(ZERO);                                                                 
01120600       INSYMBOL;                                                                    
01120700       IF (SYMBOL = COMMA) THEN INSYMBOL                                            
01120800       ELSE IF (SYMBOL NEQ RPARENT) THEN ERROR(2903);                               
01120900     END;                                                                           
01121000   END ELSE BEGIN                                                                   
01121100     IF NOTKEYED THEN GENOP(ZERO);                                                  
01121200     FREEFIELDIO;                                                                   
01121300     IF (FREEFIELDSYMBOL) THEN BEGIN                                                
01121400       INSYMBOL;                                                                    
01121500       IF (SYMBOL = COMMA) THEN INSYMBOL                                            
01121600       ELSE IF (SYMBOL NEQ RPARENT) THEN ERROR(2904);                               
01121700     END ELSE BEGIN                                                                 
01121800       IF (SYMBOL NEQ RPARENT) AND NOT SYMBOLIN(STATBEGSYS) THEN BEGIN              
01121900         ERROR(2905);                                                               
01122000         SKIP(COMMARPARENTSET);                                                     
01122100       END;                                                                         
01122200     END;                                                                           
01122300   END;                                                                             
01122400 END;                                                                               
01122500 IF (GETPUT) THEN BEGIN                                                             
01122600   IF ((FILELEV=BASELVL) AND (FILEADDR=ADDRIFILE)) THEN GENLIT(80)                  
01122700   ELSE IF ((FILELEV=BASELVL) AND (FILEADDR=ADDROFILE)) THEN                        
01122800             GENLIT(132)                                                            
01122900        ELSE GENLIT(ARRAYSIZE);                                                     
01123000 END;                                                                               
01123100 IF (SYMBOL NEQ RPARENT) THEN BEGIN                                                 
01123200   LAB := MAKELABEL;                                                                
01123300   GENBR(BRUN,LAB);                                                                 
01123400   READWRITESTMT := READREC;                                                        
01123500   IOLIST(LCPCW);                                                                   
01123600   GENLABEL(LAB);                                                                   
01123700   GENV(NAMC,LEXLEVEL,LCPCW);                                                       
01123800   GENOP(STFF);                                                                     
01123900 END ELSE BEGIN                                                                     
01124000   GENOP(ZERO);                                                                     
01124100 END;                                                                               
01124200 IF FREEFIELD THEN BEGIN                                                            
01124300   GENOP(ZERO);                                                                     
01124400   GENOP(ZERO);                                                                     
01124500   GENLIT(MAXFIELDSIZE);                                                            
01124600 END;                                                                               
01124700 IF SEEKSPACE THEN BEGIN                                                            
01124800   GENV(NAMC,00,02);                                                                
01124900   GENOP(LOAD);                                                                     
01125000 END;                                                                               
01125100 IF GETPUT THEN BEGIN                                                               
01125200   GENV(NAMC,FILELEV,FILEADDR+1);                                                   
01125300   GENOP(INDX);                                                                     
01125400 END;                                                                               
01125500 FORMCHOOSEWORD;                                                                    
01125600 GENLIT(CHOOSEWORD);                                                                
01125700 GENOP(ENTR);                                                                       
01125800 IF (SPACESTATEMENT ) THEN                                                          
01125900 BEGIN                                                                              
01126000   GENOP(DUPL);                                                                     
01126100   LAB := MAKELABEL;                                                                
01126200   GENBR(BRFL,LAB);                                                                 
01126300   GENV(NAMC,0,IOERR);                                                              
01126400   GENOP(EXCH);                                                                     
01126500   GENOP(IMKS);                                                                     
01126600   GENV(NAMC,FILELEV,FILEADDR);                                                     
01126700   GENOP(STFF);                                                                     
01126800   GENOP(ENTR);                                                                     
01126900   GENLABEL(LAB);                                                                   
01127000 END;                                                                               
01127100 GENOP(ZERO);  GENV(NAMC,FILELEV,FILEADDR+2);                                       
01127200 GENOP(INDX);  GENOP(STOD);                                                         
01127300 AWAY:                                                                              
01127400 END;      %OF READWRITESTATEMENT                                                   
01127500                                                                                    
01127600 %-----------------------------------------------------------------------           
01127700                                                                                    
01127800                                                                                    
01127900  $SET OMIT = NOT CODETEST                                                          
01128000 PROCEDURE CODETEST;                                                                
01128100 %         ********                                                                 
01128200 BEGIN                                                                              
01128300   IF (SYMBOL = INTCONST) THEN BEGIN                                                
01128400     CASE VAL OF BEGIN                                                              
01128500  $INCLUDE CODETEST                                                                 
01128600     ELSE:                                                                          
01128700       GENOP(NVLD);                                                                 
01128800     END;   %OF CASE                                                                
01128900   END;   %OF IF - IGNORE IF NOT CONSTANT                                           
01129000   INSYMBOL;                                                                        
01129100 END;   %OF CODETEST                                                                
01129200  $POP OMIT                                                                         
01129300                                                                                    
01129400   DEFINE                                                                           
01129500     %===================================================================           
01129600     %   SYSTEM INTRINSICS                                                          
01129700     %===================================================================           
01129800     SIN=25#,                                                                       
01129900     COS=20#,                                                                       
01130000     ARCTAN=3#,                                                                     
01130100     EXP=32#,                                                                       
01130200     LN=18#,                                                                        
01130300     SQRT=1#,                                                                       
01130400     TAN=23#,                                                                       
01130500     COTAN=39#,                                                                     
01130600     ARCSIN=9#,                                                                     
01130700     ARCCOS=2#,                                                                     
01130800     ARCTAN2=35#,                                                                   
01130900     SINH=14#,                                                                      
01131000     COSH=5#,                                                                       
01131100     TANH=30#,                                                                      
01131200     ATANH=83#,                                                                     
01131300     LOG=22#,                                                                       
01131400     ERF=37#,                                                                       
01131500     ERFC=94#,                                                                      
01131600     GAMMA=6#,                                                                      
01131700     LNGAMMA=36#,                                                                   
01131800     RANDOMINTR=7#,                                                                 
01131900     TIMEINTR=24#,                                                                  
01132000     ATTRIBHANDLER = 42#,                                                           
01132100     ZIPINTR = 50#,                                                                 
01132200     MUTATE = 103#,                                                                 
01132300     MYSELFER = 104#,                                                               
01132400     CLOSEINTR = 27#;                                                               
01132500                                                                                    
01132600 PROCEDURE CALLSTANDARD(FSYS,FCP);                                                  
01132700 %         ************                                                             
01132800 VALUE FSYS,FCP;                                                                    
01132900 TYPESETOFSYS FSYS;                                                                 
01133000 TYPEIDENTPTR FCP;                                                                  
01133100 BEGIN                                                                              
01133200   INTEGER LKEY;                                                                    
01133300   BOOLEAN PARAMS;                                                                  
01133400                                                                                    
01133500                                                                                    
01133600                                                                                    
01133700 PROCEDURE VARIABLE(FSYS);                                                          
01133800 %         ********                                                                 
01133900 VALUE FSYS;                                                                        
01134000 TYPESETOFSYS FSYS;                                                                 
01134100 BEGIN                                                                              
01134200   TYPEIDENTPTR LCP;                                                                
01134300   %                                                                                
01134400   IF (SYMBOL = IDENT) THEN BEGIN                                                   
01134500     SEARCHID(VARFLDSET,LCP);                                                       
01134600     INSYMBOL;                                                                      
01134700   END ELSE BEGIN                                                                   
01134800     ERROR(2723);                                                                   
01134900     LCP:=UVARPTR;                                                                  
01135000   END;                                                                             
01135100   SELECTOR(FSYS,LCP);                                                              
01135200 END;   %OF VARIABLE                                                                
01135300                                                                                    
01135400 PROCEDURE INTRINSICCALL(INTADDR,INTRINSICNO);                                      
01135500 %         *************                                                            
01135600 VALUE INTRINSICNO;                                                                 
01135700 INTEGER INTADDR,INTRINSICNO;                                                       
01135800 BEGIN                                                                              
01135900   GENOP(MKST);                                                                     
01136000   GENV(NAMC,1,INTRINSICADDR(INTADDR,INTRINSICNO));                                 
01136100   IF (INTRINSICNO = ARCTAN2) THEN BEGIN                                            
01136200     EXPRESSION(FSYS OR COMMASET);                                                  
01136300     LOADV;                                                                         
01136400     IF(GTYPTR NEQ REALPTR) THEN BEGIN                                              
01136500       IF COMPTYPES(GTYPTR,INTPTR) THEN BEGIN                                       
01136600         GTYPTR := REALPTR;                                                         
01136700       END ELSE BEGIN                                                               
01136800         ERROR(2866);                                                               
01136900         GTYPTR := REALPTR;                                                         
01137000       END;                                                                         
01137100     END;                                                                           
01137200     IF (SYMBOL=COMMA) THEN INSYMBOL ELSE ERROR(2860);                              
01137300   END;                                                                             
01137400   EXPRESSION(FSYS OR RPARENTSET);                                                  
01137500   LOADV;                                                                           
01137600   IF(GTYPTR NEQ REALPTR) THEN BEGIN                                                
01137700     IF COMPTYPES(GTYPTR,INTPTR) THEN BEGIN                                         
01137800       GTYPTR := REALPTR;                                                           
01137900     END ELSE BEGIN                                                                 
01138000       ERROR(2866);                                                                 
01138100       GTYPTR := REALPTR;                                                           
01138200     END;                                                                           
01138300   END;                                                                             
01138400   GENOP(ENTR);                                                                     
01138500 END;                                                                               
01138600                                                                                    
01138700 PROCEDURE BUFFFLUSH;                                                               
01138800 %         *********                                                                
01138900 BEGIN                                                                              
01139000   INTEGER LAB;                                                                     
01139100   IF(FILTYPE(GTYPTR)=CHARBUFPTR) OR (FILTYPE(GTYPTR)=WORDBUFPTR) THEN              
01139200   BEGIN                                                                            
01139300     GENOP(ONE); GENV(VALC,GVLEVEL,GDPLMT+2);                                       
01139400     GENOP2(ISOL,3,4);                                                              
01139500     GENOP1(LT8,3);                                                                 
01139600     GENOP(EQUL);                                                                   
01139700     LAB:=MAKELABEL;                                                                
01139800     GENBR(BRFL,LAB);                                                               
01139900     IF(FILTYPE(GTYPTR)=CHARBUFPTR) THEN GENOP1(LT8,6)                              
01140000                                    ELSE GENOP1(LT8,3);                             
01140100     GENV(VALC,GVLEVEL,GDPLMT+2);                                                   
01140200     GENOP(ZERO);                                                                   
01140300     GENOP(EQUL);                                                                   
01140400     GENBR(BRTR,LAB);    %NOTHING TO FLUSH                                          
01140500     GENOP(MKST);                                                                   
01140600     GENV(NAMC,1,INTRINSICADDR(PASCALTEXTWRITEADDR,                                 
01140700            PASCALINTRINSIC(PASCALTEXTWRITEINTR)));                                 
01140800     GENV(NAMC,GVLEVEL,GDPLMT); GENOP(STFF);                                        
01140900     GENV(NAMC,GVLEVEL,GDPLMT+1); GENOP(LOAD);                                      
01141000     GENV(NAMC,GVLEVEL,GDPLMT+2); GENOP(LOAD);                                      
01141100     GENOP(ZERO);                                                                   
01141200     GENOP(DUPL); GENOP(DUPL); GENOP(DUPL); GENOP(DUPL);                            
01141300     GENLIT(7 & 1[47:1] );                                                          
01141400     IF FILTYPE(GTYPTR)=WORDBUFPTR THEN GENOP1(BSET,44);                            
01141500     GENOP(ENTR);                                                                   
01141600     GENLABEL(LAB);                                                                 
01141700   END ELSE BEGIN                                                                   
01141800     GENOP(MKST);                                                                   
01141900     GENV(NAMC,1,INTRINSICADDR(PASCALFLUSHFILEADDR,                                 
01142000                 PASCALINTRINSIC(PASCALFLUSHBUFFERINTR)));                          
01142100     GENV(NAMC,GVLEVEL,GDPLMT);  GENOP(STFF);                                       
01142200     GENV(NAMC,GVLEVEL,GDPLMT+1);  GENOP(LOAD);                                     
01142300     GENV(NAMC,GVLEVEL,GDPLMT+2);  GENOP(LOAD);                                     
01142400     GENOP(ENTR);                                                                   
01142500   END;                                                                             
01142600 END;                                                                               
01142700                                                                                    
01142800 PROCEDURE CARDCALL;                                                                
01142900 %         ********                                                                 
01143000 BEGIN                                                                              
01143100   EXPRESSION(FSYS OR RPARENTSET);                                                  
01143200   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01143300     IF (FORM(GTYPTR) = POWER) THEN BEGIN                                           
01143400       IF (SETTYPE(GTYPTR)=LSET) THEN BEGIN                                         
01143500         LOADIRW;                                                                   
01143600         GENOP(IMKS);                                                               
01143700         GENV(NAMC,1,INTRINSICADDR(PASCALLONGSETCARDINALITYADDR,                    
01143800            PASCALINTRINSIC(PASCALLONGSETCARDINALITYINTR)));                        
01143900         GENOP(RSDN);                                                               
01144000         GENLIT(SWORDS(GTYPTR));                                                    
01144100         GENOP(ENTR);                                                               
01144200       END ELSE BEGIN                                                               
01144300         LOADV;                                                                     
01144400         GENOP(CBON);                                                               
01144500       END;                                                                         
01144600       GETBOUNDS(ELSET(GTYPTR),GBMIN,GBMAX);                                        
01144700       GBMAX:=GBMAX-GBMIN+1;                                                        
01144800       GBMIN:=0;                                                                    
01144900     END ELSE BEGIN                                                                 
01145000       ERROR(2854);                                                                 
01145100     END;                                                                           
01145200     GTYPTR:=INTPTR;                                                                
01145300   END;                                                                             
01145400 END;                                                                               
01145500                                                                                    
01145600 PROCEDURE RANDOM;                                                                  
01145700 %         ******                                                                   
01145800 BEGIN                                                                              
01145900   GENOP(MKST);                                                                     
01146000   GENV(NAMC,1,INTRINSICADDR(RANDOMADDR,RANDOMINTR));                               
01146100   EXPRESSION(FSYS OR RPARENTSET);                                                  
01146200   GENV(NAMC,GVLEVEL,GDPLMT);                                                       
01146300   GENOP(STFF);                                                                     
01146400   GENOP(ENTR);                                                                     
01146500   GTYPTR:=REALPTR;                                                                 
01146600 END;                                                                               
01146700                                                                                    
01146800 PROCEDURE TIMECALL(TIMETYPE);                                                      
01146900 %         ********                                                                 
01147000 VALUE TIMETYPE;                                                                    
01147100 INTEGER TIMETYPE;                                                                  
01147200 BEGIN                                                                              
01147300   GENOP(MKST);                                                                     
01147400   GENV(NAMC,00,TIMEINTR);                                                          
01147500   GENOP1(LT8,TIMETYPE);                                                            
01147600   GENOP(ENTR);                                                                     
01147700   GENLIT(2.4@-6);  GENOP(MULT);                                                    
01147800   GTYPTR := REALPTR;                                                               
01147900 END;                                                                               
01148000                                                                                    
01148100 PROCEDURE HALT;                                                                    
01148200 %         ****                                                                     
01148300 BEGIN                                                                              
01148400 TYPEDISPRANGE                                                                      
01148500   LTOP;                                                                            
01148600   LTOP := TOP;                                                                     
01148700   WHILE (OCCUR(LTOP) NEQ BLCK) DO LTOP :=*-DISPLAYSIZE;                            
01148800   TRAVERSETREE(FNAME(LTOP));                                                       
01148900   GENOP(MKST);                                                                     
01149000   GENV(NAMC,1,INTRINSICADDR(PASCALFLUSHFILEADDR,                                   
01149100               PASCALINTRINSIC(PASCALFLUSHBUFFERINTR)));                            
01149200   GENV(NAMC,2,ADDROFILE); GENOP(STFF);                                             
01149300   GENV(NAMC,2,ADDROBUF); GENOP(LOAD);                                              
01149400   GENV(NAMC,2,ADDROFILEDATA); GENOP(LOAD);                                         
01149500   GENOP(ENTR);                                                                     
01149600   GENOP(MKST);  GENV(NAMC,00,MUTATE);                                              
01149700   GENOP(MKST);  GENV(NAMC,00,MYSELFER);                                            
01149800   GENOP(ENTR);  GENOP1(LT8,12);                                                    
01149900   GENOP(ONE);   GENOP(CHSN);                                                       
01150000   GENOP(ENTR);                                                                     
01150100 END;                                                                               
01150200                                                                                    
01150300 PROCEDURE TIMESTAMP;                                                               
01150400 %         *********                                                                
01150500 BEGIN                                                                              
01150600   GENOP(MKST);                                                                     
01150700   GENV(NAMC,1,INTRINSICADDR(PASCALTIMESTAMPADDR,                                   
01150800        PASCALINTRINSIC(PASCALTIMESTAMPINTR)));                                     
01150900   EXPRESSION(FSYS OR RPARENTSET);                                                  
01151000   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01151100     IF (FORM(GTYPTR) NEQ ARRAYS) OR (BITS(GTYPTR) NEQ BITSPERWORD)                 
01151200     THEN BEGIN                                                                     
01151300       ERROR(2880);                                                                 
01151400     END;                                                                           
01151500   END;                                                                             
01151600   LOADIRW;                                                                         
01151700   GENOP(ENTR);                                                                     
01151800 END;                                                                               
01151900                                                                                    
01152000 PROCEDURE CLOSE;                                                                   
01152100 %         *****                                                                    
01152200 BEGIN                                                                              
01152300   DEFINE                                                                           
01152400     RESET = (LKEY=17)#,                                                            
01152500     REWRITE = (LKEY=18)#;                                                          
01152600   TYPEIDENTPTR LCP;                                                                
01152700   INTEGER LAB,LABA,LCPCW;                                                          
01152800   REAL PCWPOSN;                                                                    
01152900   DECLARELATTR;                                                                    
01153000                                                                                    
01153100   IF (SYMBOL = IDENT) THEN BEGIN                                                   
01153200     SEARCHID(VARFLDSET,LCP);                                                       
01153300     INSYMBOL;                                                                      
01153400   END ELSE BEGIN                                                                   
01153500     ERROR(2723);                                                                   
01153600     LCP:=UVARPTR;                                                                  
01153700   END;                                                                             
01153800   SELECTOR(FSYS OR COMMARPARENTSET,LCP);                                           
01153900   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01154000     IF (FORM(GTYPTR) NEQ FILES) THEN BEGIN                                         
01154100       ERROR(2861);                                                                 
01154200     END;                                                                           
01154300   END;                                                                             
01154400   BUFFFLUSH;                                                                       
01154500   GENOP(MKST);  GENV(NAMC,00,CLOSEINTR);                                           
01154600   GENV(NAMC,GVLEVEL,GDPLMT);  GENOP(STFF);                                         
01154700   IF (RESET OR REWRITE) THEN BEGIN                                                 
01154800     GENOP(ZERO);                                                                   
01154900   END ELSE BEGIN                                                                   
01155000     IF (SYMBOL = COMMA) THEN BEGIN                                                 
01155100       INSYMBOL;                                                                    
01155200       IF (SYMBOL = IDENT) THEN BEGIN                                               
01155300         IF (NAMEBUF1 = "REWIND") THEN GENOP(ZERO)                                  
01155400         ELSE                                                                       
01155500         IF (NAMEBUF1 = "NORMAL") THEN GENOP(ONE)                                   
01155600         ELSE                                                                       
01155700         IF (NAMEBUF1 = "PURGE") THEN GENOP1(LT8,2)                                 
01155800         ELSE                                                                       
01155900         IF (NAMEBUF1 = "LOCK") THEN GENOP1(LT8,4)                                  
01156000         ELSE                                                                       
01156100         IF (NAMEBUF1 = "CRUNCH") THEN GENOP1(LT8,5)                                
01156200         ELSE                                                                       
01156300         IF (NAMEBUF1 = "TAPEMARK") THEN GENOP1(LT8,7)                              
01156400         ELSE                                                                       
01156500         IF (NAMEBUF1 = "REEL") THEN BEGIN                                          
01156600           GENOP(ZERO);  GENOP(CHSN);                                               
01156700         END                                                                        
01156800         ELSE                                                                       
01156900         ERROR(2862);          %INVALID OPERATION                                   
01157000       END ELSE BEGIN                                                               
01157100         ERROR(2862);         %INVALID OPERATION                                    
01157200       END;                                                                         
01157300       INSYMBOL;                                                                    
01157400     END ELSE BEGIN                                                                 
01157500       GENOP(ONE);                                                                  
01157600     END;                                                                           
01157700   END;                                                                             
01157800   GENOP(ENTR);                                                                     
01157900                  %RESET STATUS BLOCK                                               
01158000   GENOP(ONE);  GENV(NAMC,GVLEVEL,GDPLMT+2);  GENOP(INDX);                          
01158100   GENOP(ZERO);  GENOP(STOD);                                                       
01158200   GENOP(ZERO);  GENV(NAMC,GVLEVEL,GDPLMT+2);  GENOP(INDX);                         
01158300   GENOP(ZERO);                                                                     
01158400   GENOP(STOD);                                                                     
01158500   IF (RESET OR REWRITE) THEN BEGIN                                                 
01158600     IF (SYMBOL=COMMA) THEN BEGIN                                                   
01158700       IF STANDARDTOG THEN ERROR(1853);                                             
01158800       GENOP(MKST);                                                                 
01158900       GENV(NAMC,0,ATTRIBHANDLER);                                                  
01159000       GENV(NAMC,GVLEVEL,GDPLMT);                                                   
01159100       GENOP(STFF);                                                                 
01159200       GENOP(ZERO);                                                                 
01159300       COPYLATTRGATTR;                                                              
01159400       INSYMBOL;                                                                    
01159500       EXPRESSION(FSYS OR RPARENTSET);                                              
01159600       IF STRING(GTYPTR) THEN BEGIN                                                 
01159700         LOADINXDDESCRIPTOR;                                                        
01159800       END ELSE BEGIN                                                               
01159900         ERROR(2850);                                                               
01160000       END;                                                                         
01160100       GENOP(ENTR);                                                                 
01160200       COPYGATTRLATTR;                                                              
01160300     END;                                                                           
01160400     IF (FILTYPE(GTYPTR)=CHARBUFPTR) OR (FILTYPE(GTYPTR)=WORDBUFPTR) THEN           
01160500     BEGIN                                                                          
01160600       GENOP(MKST);                                                                 
01160700       GENV(NAMC,1,INTRINSICADDR(PASCALTEXTOPENADDR,                                
01160800             PASCALINTRINSIC(PASCALTEXTOPENINTR)));                                 
01160900       GENV(NAMC,VLEV(LCP),VADDR(LCP));                                             
01161000       IF (VKIND(LCP)=FORMAL) THEN GENOP(LOAD)                                      
01161100                              ELSE GENOP(STFF);                                     
01161200       GENV(NAMC,VLEV(LCP),VADDR(LCP)+1); GENOP(LOAD);                              
01161300       GENV(NAMC,VLEV(LCP),VADDR(LCP)+2); GENOP(LOAD);                              
01161400       GENLIT(LKEY);                                                                
01161500       IF (FILTYPE(GTYPTR)=WORDBUFPTR) THEN GENOP(ONE)                              
01161600                                       ELSE GENOP(ZERO);                            
01161700       IF STRIPBLANKSTOG AND RESET THEN GENOP1(BSET,46);                            
01161800       GENOP(ENTR);                                                                 
01161900     END ELSE BEGIN                                                                 
01162000       GENOP(MKST);                                                                 
01162100       IF RESET THEN BEGIN                                                          
01162200         GENV(NAMC,1,INTRINSICADDR(PASCALREADADDR,                                  
01162300               PASCALINTRINSIC(PASCALREADINTR)));                                   
01162400       END ELSE BEGIN                                                               
01162500         GENV(NAMC,1,INTRINSICADDR(PASCALWRITEADDR,                                 
01162600               PASCALINTRINSIC(PASCALWRITEINTR)));                                  
01162700       END;                                                                         
01162800       GENV(NAMC,VLEV(LCP),VADDR(LCP));                                             
01162900       IF (VKIND(LCP)=FORMAL) THEN GENOP(LOAD)                                      
01163000                              ELSE GENOP(STFF);                                     
01163100       GENV(NAMC,VLEV(LCP),VADDR(LCP)+1); GENOP(LOAD);                              
01163200       GENV(NAMC,VLEV(LCP),VADDR(LCP)+2); GENOP(LOAD);                              
01163300       LAB:=MAKELABEL;                                                              
01163400       GENBR(BRUN,LAB);                                                             
01163500       LEXLEVEL:=*+1;                                                               
01163600       LABA:=MAKELABEL;                                                             
01163700       GENLABEL(LABA);                                                              
01163800       PCWPOSN:=ASKFORPCW(LABA) & 0 [47:1];                                         
01163900       GENERATEPCWWORD(PCWPOSN,NIL);                                                
01164000       LCPCW:=LC;                                                                   
01164100       LEXLEVEL:=*-1;                                                               
01164200       LC:=LC+1;                                                                    
01164300       GENOP(ZERO);                                                                 
01164400       GENOP(RETN);                                                                 
01164500       GENLABEL(LAB);                                                               
01164600       GENV(NAMC,LEXLEVEL,LCPCW);                                                   
01164700       GENOP(STFF);                                                                 
01164800       IF RESET THEN BEGIN                                                          
01164900         GENLIT(0&(IF ASCIITOG THEN 1 ELSE 0) [0:1]);                               
01165000       END;                                                                         
01165100       GENOP(ENTR);                                                                 
01165200       IF RESET THEN BEGIN                                                          
01165300         GENOP(DLET);                                                               
01165400       END;                                                                         
01165500     END;                                                                           
01165600   END;                                                                             
01165700 END;                                                                               
01165800                                                                                    
01165900 PROCEDURE SEEK;                                                                    
01166000 %         ****                                                                     
01166100 BEGIN                                                                              
01166200   READRECWRITEREC(LKEY);                                                           
01166300 END;                                                                               
01166400                                                                                    
01166500 PROCEDURE SPACE;                                                                   
01166600 %         *****                                                                    
01166700 BEGIN                                                                              
01166800   READRECWRITEREC(LKEY);                                                           
01166900 END;                                                                               
01167000                                                                                    
01167100 PROCEDURE READWRITEPROC(LKEY);                                                     
01167200 %         *************                                                            
01167300 VALUE LKEY;                                                                        
01167400 INTEGER LKEY;                                                                      
01167500 BEGIN                                                                              
01167600 BOOLEAN                                                                            
01167700   PARENS;                                                                          
01167800 PARENS:=FALSE;                                                                     
01167900 IF (SYMBOL=LPARENT) THEN BEGIN                                                     
01168000   INSYMBOL;                                                                        
01168100   PARENS:=TRUE;                                                                    
01168200 END ELSE BEGIN                                                                     
01168300   IF (NOT SYMBOLIN(SEMICOLONENDELSEUNTILSET)) THEN ERROR(2876);                    
01168400 END;                                                                               
01168500 IF (LKEY=22 OR LKEY=23) THEN BEGIN                                                 
01168600   READRECWRITEREC(LKEY);                                                           
01168700 END ELSE BEGIN                                                                     
01168800   STREAMIO(LKEY);                                                                  
01168900 END;                                                                               
01169000 IF PARENS THEN BEGIN                                                               
01169100   IF (SYMBOL=RPARENT) THEN INSYMBOL                                                
01169200   ELSE ERROR(2879);                                                                
01169300 END;                                                                               
01169400 END;                                                                               
01169500                                                                                    
01169600 PROCEDURE NEWPAGE;                                                                 
01169700 %         *******                                                                  
01169800 BEGIN                                                                              
01169900 BOOLEAN                                                                            
01170000   PARENS;                                                                          
01170100   IF (SYMBOL=LPARENT) THEN BEGIN                                                   
01170200     PARENS:=TRUE;                                                                  
01170300     INSYMBOL;                                                                      
01170400     VARIABLE(FSYS OR RPARENTSET);                                                  
01170500   END ELSE BEGIN                                                                   
01170600     GVLEVEL:=BASELVL;  GDPLMT:=ADDROFILE;                                          
01170700     PARENS:=FALSE;                                                                 
01170800   END;                                                                             
01170900   IF (GTYPTR NEQ NIL) OR (NOT PARENS) THEN BEGIN                                   
01171000     IF ((FORM(GTYPTR) NEQ FILES) AND PARENS) THEN BEGIN                            
01171100       ERROR(2863);                                                                 
01171200     END;                                                                           
01171300   END;                                                                             
01171400   BUFFFLUSH;                                                                       
01171500   GENOP(MKST);                                                                     
01171600   GENOP(ZERO);                                                                     
01171700   GENV(NAMC,GVLEVEL,GDPLMT);                                                       
01171800   GENOP(INDX);  GENOP(LOAD);                                                       
01171900   GENOP1(LT8,2);  GENOP(LOR);                                                      
01172000   GENOP(ONE);  GENOP(ZERO);                                                        
01172100   GENV(NAMC,0,2);  GENOP(LOAD);                                                    
01172200   GENLIT(4"080000000288");                                                         
01172300   GENOP(ENTR);                                                                     
01172400   GENOP(DLET);                                                                     
01172500   IF PARENS THEN BEGIN                                                             
01172600     IF (SYMBOL=RPARENT) THEN INSYMBOL                                              
01172700     ELSE ERROR(2879);                                                              
01172800   END;                                                                             
01172900 END;                                                                               
01173000                                                                                    
01173100 PROCEDURE STARTJOB;                                                                
01173200 %         ********                                                                 
01173300 BEGIN                                                                              
01173400   VARIABLE(FSYS OR RPARENTSET);                                                    
01173500   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01173600     IF (FORM(GTYPTR) NEQ FILES) THEN BEGIN                                         
01173700       ERROR(2863);                                                                 
01173800     END;                                                                           
01173900   END;                                                                             
01174000   GENOP(MKST);                                                                     
01174100   GENV(NAMC,00,ZIPINTR);                                                           
01174200   GENV(NAMC,GVLEVEL,GDPLMT);                                                       
01174300   GENOP(STFF);                                                                     
01174400   GENOP(ENTR);                                                                     
01174500 END;                                                                               
01174600                                                                                    
01174700 PROCEDURE MAXMIN;                                                                  
01174800 %         ******                                                                   
01174900 BEGIN                                                                              
01175000   INTEGER LAB;                                                                     
01175100   TYPESTRUCTPTR TYPE1;                                                             
01175200   REAL LBMIN,LBMAX;                                                                
01175300   EXPRESSION(FSYS OR COMMARPARENTSET);                                             
01175400   LOADV;                                                                           
01175500   LBMIN:=GBMIN;  LBMAX := GBMAX;                                                   
01175600   TYPE1 := GTYPTR;                                                                 
01175700   WHILE (SYMBOL=COMMA) DO BEGIN                                                    
01175800     INSYMBOL;                                                                      
01175900     GENOP(DUPL);                                                                   
01176000     EXPRESSION(FSYS OR COMMARPARENTSET);                                           
01176100     IF NOT COMPTYPES(TYPE1,GTYPTR) THEN ERROR(2878);                               
01176200     LOADV;                                                                         
01176300     GENOP(DUPL);                                                                   
01176400     GENOP(RSDN);                                                                   
01176500     IF (LKEY=34) THEN GENOP(LESS)                                                  
01176600                  ELSE GENOP(GRTR);                                                 
01176700     LAB := MAKELABEL;                                                              
01176800     GENBR(BRTR,LAB);                                                               
01176900     GENOP(EXCH);                                                                   
01177000     GENLABEL(LAB);                                                                 
01177100     GENOP(DLET);                                                                   
01177200     IF COMPTYPES(GTYPTR,INTPTR) OR COMPTYPES(GTYPTR,CHARPTR) THEN BEGIN            
01177300       IF (LKEY=35) THEN BEGIN                                                      
01177400         GBMAX := MAX(GBMAX,LBMAX);                                                 
01177500         GBMIN := MAX (GBMIN,LBMIN);                                                
01177600       END ELSE BEGIN                                                               
01177700         GBMIN := MIN(GBMIN,LBMIN);                                                 
01177800         GBMAX := MIN(GBMAX,LBMAX);                                                 
01177900       END;                                                                         
01178000       LBMIN:=GBMIN;                                                                
01178100       LBMAX := GBMAX;                                                              
01178200     END;                                                                           
01178300   END;                                                                             
01178400 END;                                                                               
01178500                                                                                    
01178600 PROCEDURE ABS;                                                                     
01178700 %         ***                                                                      
01178800 BEGIN                                                                              
01178900 REAL TEMP;                                                                         
01179000   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01179100     IF (NOT COMPTYPES(GTYPTR,INTPTR)) AND (GTYPTR NEQ REALPTR)                     
01179200       THEN ERROR(2865);                                                            
01179300     GENOP1(BRST,46);                                                               
01179400     IF COMPTYPES(GTYPTR,INTPTR) THEN BEGIN                                         
01179500       IF (GBMIN<0) THEN BEGIN                                                      
01179600         IF (GBMAX >= 0) THEN BEGIN                                                 
01179700           GBMAX := MAX(GBMAX,-GBMIN);                                              
01179800           GBMIN :=0;                                                               
01179900         END ELSE BEGIN                                                             
01180000           TEMP:=-GBMIN;                                                            
01180100           GBMIN := -GBMAX;                                                         
01180200           GBMAX :=TEMP;                                                            
01180300         END;                                                                       
01180400       END;                                                                         
01180500     END;                                                                           
01180600   END;                                                                             
01180700 END;                                                                               
01180800                                                                                    
01180900                                                                                    
01181000 PROCEDURE SQR;                                                                     
01181100 %         ***                                                                      
01181200 BEGIN                                                                              
01181300 REAL TEMP;                                                                         
01181400   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01181500     IF (NOT COMPTYPES(GTYPTR,INTPTR)) AND (GTYPTR NEQ REALPTR)                     
01181600       THEN ERROR(2865);                                                            
01181700     GENOP(DUPL); GENOP(MULT);;                                                     
01181800     IF COMPTYPES(GTYPTR,INTPTR) THEN BEGIN                                         
01181900       IF (GBMIN<0) THEN BEGIN                                                      
01182000         IF (GBMAX >= 0) THEN BEGIN                                                 
01182100           GBMAX := MAX(GBMAX,-GBMIN);                                              
01182200           GBMIN :=0;                                                               
01182300         END ELSE BEGIN                                                             
01182400           TEMP:=-GBMIN;                                                            
01182500           GBMIN := -GBMAX;                                                         
01182600           GBMAX :=TEMP;                                                            
01182700         END;                                                                       
01182800       END;                                                                         
01182900       SETEXPRBOUNDS(GBMIN,GBMAX,GBMIN,GBMAX,MUL);                                  
01183000     END;                                                                           
01183100   END;                                                                             
01183200 END;                                                                               
01183300                                                                                    
01183400                                                                                    
01183500 PROCEDURE TRUNC;                                                                   
01183600 %         *****                                                                    
01183700 BEGIN                                                                              
01183800   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01183900     IF (GTYPTR NEQ REALPTR) THEN ERROR(2866);                                      
01184000     GENOP(NTIA); GTYPTR:=INTPTR;;                                                  
01184100     GBMIN:=-MAXINT;  GBMAX :=MAXINT;                                               
01184200   END;                                                                             
01184300 END;                                                                               
01184400                                                                                    
01184500                                                                                    
01184600 PROCEDURE ROUND;                                                                   
01184700 %         *****                                                                    
01184800 BEGIN                                                                              
01184900   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01185000     IF (GTYPTR NEQ REALPTR) THEN ERROR(2866);                                      
01185100     GENOP(NTGR); GTYPTR:=INTPTR;;                                                  
01185200     GBMIN:=-MAXINT;  GBMAX :=MAXINT;                                               
01185300   END;                                                                             
01185400 END;                                                                               
01185500                                                                                    
01185600                                                                                    
01185700 PROCEDURE ODD;                                                                     
01185800 %         ***                                                                      
01185900 BEGIN                                                                              
01186000   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01186100     IF (NOT COMPTYPES(GTYPTR,INTPTR)) THEN ERROR(2864);                            
01186200     GENOP(NTGR);                                                                   
01186300     GENOP(ONE); GENOP(LAND); GTYPTR:=BOOLPTR;                                      
01186400   END;                                                                             
01186500 END;                                                                               
01186600                                                                                    
01186700                                                                                    
01186800 PROCEDURE ORD;                                                                     
01186900 %         ***                                                                      
01187000 BEGIN                                                                              
01187100   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01187200     IF (FORM(GTYPTR) >= POWER) THEN ERROR(2867);                                   
01187300     GTYPTR:=INTPTR;;                                                               
01187400     GBMIN:=-MAXINT;  GBMAX :=MAXINT;                                               
01187500   END;                                                                             
01187600 END;                                                                               
01187700                                                                                    
01187800                                                                                    
01187900 PROCEDURE CHR;                                                                     
01188000 %         ***                                                                      
01188100 BEGIN                                                                              
01188200   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01188300     IF (NOT COMPTYPES(GTYPTR,INTPTR)) THEN ERROR(2864);                            
01188400     GENOP(NTGR);                                                                   
01188500     RANGECHECK(0,IF ASCIITOG THEN 127 ELSE 255,GBMIN,GBMAX);                       
01188600     GENOP2(ISOL,7,8);                                                              
01188700     GTYPTR:=CHARPTR;;                                                              
01188800   END;                                                                             
01188900 END;                                                                               
01189000                                                                                    
01189100                                                                                    
01189200 PROCEDURE PREDSUCC;                                                                
01189300 %         ********                                                                 
01189400 BEGIN                                                                              
01189500   INTEGER LMIN,LMAX,LABELA;                                                        
01189600   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01189700     IF (FORM(GTYPTR) > SUBRANGE) OR (GTYPTR = REALPTR) THEN BEGIN                  
01189800       ERROR(2868);                                                                 
01189900     END ELSE BEGIN                                                                 
01190000       IF (NOT COMPTYPES(GTYPTR,INTPTR)) THEN                                       
01190100         GETBOUNDS(GTYPTR,LMIN,LMAX);                                               
01190200       GENOP(ONE);                                                                  
01190300       GENOP(IF (LKEY = 8) THEN SUBT ELSE ADD);                                     
01190400       IF (NOT COMPTYPES(GTYPTR,INTPTR)) THEN BEGIN                                 
01190500         GENOP(DUPL);                                                               
01190600         IF (LKEY = 8) THEN BEGIN                                                   
01190700           GENLIT(LMIN); GENOP(LESS);                                               
01190800         END ELSE BEGIN                                                             
01190900           GENLIT(LMAX); GENOP(GRTR);                                               
01191000         END;                                                                       
01191100         LABELA:=MAKELABEL; GENBR(BRFL,LABELA);                                     
01191200         RUNTIMEERROR(SUCCPREDERROR);                                               
01191300         GENLABEL(LABELA);                                                          
01191400       END;                                                                         
01191500       IF (LKEY=8) THEN BEGIN                                                       
01191600         GBMIN := *-1;  GBMAX := *+1;                                               
01191700       END ELSE BEGIN                                                               
01191800         GBMIN:=*+1;  GBMAX :=*+1;                                                  
01191900       END;                                                                         
01192000     END;                                                                           
01192100   END;                                                                             
01192200 END;                                                                               
01192300                                                                                    
01192400                                                                                    
01192500 PROCEDURE EOF;                                                                     
01192600 %         ***                                                                      
01192700 BEGIN                                                                              
01192800 BOOLEAN                                                                            
01192900   PARENS;                                                                          
01193000   IF (SYMBOL=LPARENT) THEN BEGIN                                                   
01193100     PARENS:=TRUE;                                                                  
01193200     INSYMBOL;                                                                      
01193300     VARIABLE(FSYS OR RPARENTSET);                                                  
01193400   END ELSE BEGIN                                                                   
01193500     GVLEVEL:=BASELVL;  GDPLMT:=ADDRIFILE;                                          
01193600     PARENS:=FALSE;                                                                 
01193700   END;                                                                             
01193800   IF (GTYPTR NEQ NIL) OR NOT PARENS THEN BEGIN                                     
01193900     IF (FORM(GTYPTR) NEQ FILES AND PARENS) THEN ERROR(2869);                       
01194000     GDPLMT := *+2;                                                                 
01194100     GENOP(ZERO);  GENV(VALC,GVLEVEL,GDPLMT);                                       
01194200     GENOP(ONE);  GENV(VALC,GVLEVEL,GDPLMT);                                        
01194300     GENOP2(ISOL,1,1);                                                              
01194400     GENOP(LOR);  GENOP(ONE);  GENOP(LAND);                                         
01194500     GTYPTR:=BOOLPTR;                                                               
01194600   END;                                                                             
01194700   IF PARENS THEN BEGIN                                                             
01194800     IF (SYMBOL=RPARENT) THEN INSYMBOL                                              
01194900     ELSE ERROR(2879);                                                              
01195000   END;                                                                             
01195100 END;                                                                               
01195200                                                                                    
01195300                                                                                    
01195400 PROCEDURE ENDOFLINE;                                                               
01195500 %         *********                                                                
01195600 BEGIN                                                                              
01195700 BOOLEAN                                                                            
01195800   PARENS;                                                                          
01195900   IF (SYMBOL=LPARENT) THEN BEGIN                                                   
01196000     PARENS:=TRUE;                                                                  
01196100     INSYMBOL;                                                                      
01196200     VARIABLE(FSYS OR RPARENTSET);                                                  
01196300   END ELSE BEGIN                                                                   
01196400     GVLEVEL:=BASELVL;  GDPLMT:=ADDRIFILE;                                          
01196500     GTYPTR := TEXTPTR;                                                             
01196600     PARENS:=FALSE;                                                                 
01196700   END;                                                                             
01196800   IF (GTYPTR NEQ NIL)OR (NOT PARENS) THEN BEGIN                                    
01196900     IF (FORM(GTYPTR) NEQ FILES AND PARENS) THEN BEGIN                              
01197000       ERROR(2869);                                                                 
01197100     END ELSE BEGIN                                                                 
01197200       GDPLMT:=*+2;                                                                 
01197300       IF (TEXTFILE(GTYPTR)=TEXTFIL) THEN BEGIN                                     
01197400         GENOP1(LT8,6);                                                             
01197500         GENV(NAMC,GVLEVEL,GDPLMT);                                                 
01197600         GENOP(INDX);                                                               
01197700         GENOP(LOAD);                                                               
01197800         GENOP(ZERO);                                                               
01197900         GENOP(STAG);                                                               
01198000         GENLIT(5 & 1[35:16] & 1[47:12]);    %EOLN MARKER                           
01198100         GENOP(EQUL);                                                               
01198200       END ELSE BEGIN                                                               
01198300         IF STANDARDTOG THEN BEGIN                                                  
01198400           ERROR(1885);                                                             
01198500         END;                                                                       
01198600         GENOP(ZERO);  GENLIT(3);                                                   
01198700         GENV(VALC,GVLEVEL,GDPLMT);                                                 
01198800         GENOP(EQUL);                                                               
01198900       END;                                                                         
01199000       GENOP(ONE);  GENOP(DUPL);                                                    
01199100       GENV(VALC,GVLEVEL,GDPLMT);                                                   
01199200       GENOP2(ISOL,3,4);                                                            
01199300       GENOP(EQUL);  GENOP(LAND);                                                   
01199400     END;                                                                           
01199500     GTYPTR:=BOOLPTR;                                                               
01199600   END;                                                                             
01199700   IF PARENS THEN BEGIN                                                             
01199800     IF (SYMBOL=RPARENT) THEN INSYMBOL                                              
01199900     ELSE ERROR(2879);                                                              
01200000   END;                                                                             
01200100 END;                                                                               
01200200                                                                                    
01200300 PROCEDURE ENDOFFILE;                                                               
01200400 %         *********                                                                
01200500 BEGIN                                                                              
01200600 BOOLEAN                                                                            
01200700   PARENS;                                                                          
01200800   IF (SYMBOL=LPARENT) THEN BEGIN                                                   
01200900     PARENS:=TRUE;                                                                  
01201000     INSYMBOL;                                                                      
01201100     VARIABLE(FSYS OR RPARENTSET);                                                  
01201200   END ELSE BEGIN                                                                   
01201300     GVLEVEL:=BASELVL;  GDPLMT:=ADDRIFILE;                                          
01201400     PARENS:=FALSE;                                                                 
01201500   END;                                                                             
01201600   IF (GTYPTR NEQ NIL) OR (NOT PARENS) THEN BEGIN                                   
01201700     IF (FORM(GTYPTR) NEQ FILES) AND (PARENS) THEN BEGIN                            
01201800       ERROR(2869);                                                                 
01201900     END;                                                                           
01202000   END;                                                                             
01202100   GDPLMT:=*+2;                                                                     
01202200   GENOP(ZERO);                                                                     
01202300   GENV(VALC,GVLEVEL,GDPLMT);                                                       
01202400   GENOP2(ISOL,0,1);                                                                
01202500   GTYPTR:=BOOLPTR;                                                                 
01202600   IF PARENS THEN BEGIN                                                             
01202700     IF (SYMBOL=RPARENT) THEN INSYMBOL                                              
01202800     ELSE ERROR(2879);                                                              
01202900   END;                                                                             
01203000 END;                                                                               
01203100                                                                                    
01203200 PROCEDURE GETPUT;                                                                  
01203300 %         ******                                                                   
01203400 BEGIN                                                                              
01203500 LABEL                                                                              
01203600   EXIT;                                                                            
01203700 TYPEIDENTPTR                                                                       
01203800   LCP;                                                                             
01203900   SEARCHID(VARFLDSET,LCP);                                                         
01204000   IF (LCP NEQ NIL) THEN BEGIN                                                      
01204100     IF (FORM(IDTYPE(LCP))=FILES) THEN BEGIN                                        
01204200       IF (TEXTFILE(IDTYPE(LCP))=TEXTFIL) OR                                        
01204300         (FILTYPE(IDTYPE(LCP))=WORDBUFPTR) THEN BEGIN                               
01204400         STREAMIO(LKEY);                                                            
01204500         GOTO EXIT;                                                                 
01204600       END;                                                                         
01204700     END;                                                                           
01204800   END;                                                                             
01204900   READRECWRITEREC(LKEY);                                                           
01205000 EXIT:                                                                              
01205100 END; % OF GET AND PUT                                                              
01205200                                                                                    
01205300                                                                                    
01205400 PROCEDURE MARKPROC;                                                                
01205500 %         ********                                                                 
01205600 BEGIN                                                                              
01205700   VARIABLE(FSYS OR RPARENTSET);                                                    
01205800   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01205900     IF (FORM(GTYPTR) NEQ POINTERS) THEN ERROR(2870);                               
01206000   END;                                                                             
01206100   LOADIRW;                                                                         
01206200   GENV(VALC,BASELVL,ADDRHEAPPTR); GENOP(STOD);                                     
01206300 END;                                                                               
01206400                                                                                    
01206500                                                                                    
01206600 PROCEDURE RELEASEPROC;                                                             
01206700 %         ***********                                                              
01206800 BEGIN                                                                              
01206900   EXPRESSION(FSYS OR RPARENTSET);                                                  
01207000   LOADV;                                                                           
01207100   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01207200     IF (FORM(GTYPTR) NEQ POINTERS) THEN ERROR(2870);                               
01207300   END;                                                                             
01207400   GENV(NAMC,BASELVL,ADDRHEAPPTR); GENOP(STOD);                                     
01207500 END;                                                                               
01207600                                                                                    
01207700                                                                                    
01207800 PROCEDURE NEWPROC;                                                                 
01207900 %         *******                                                                  
01208000 BEGIN                                                                              
01208100   LABEL L1;                                                                        
01208200   TYPESTRUCTPTR LSP,LSP1;                                                          
01208300   INTEGER VARTS,LMIN,LMAX,LSIZE,LSZ,LABELA;                                        
01208400   REAL LVALUE;                                                                     
01208500   %                                                                                
01208600   VARIABLE(FSYS OR COMMARPARENTSET); LOADIRW;                                      
01208700   LSP:=NIL; VARTS:=LSIZE:=0;                                                       
01208800   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01208900     IF (FORM(GTYPTR) = POINTERS) THEN BEGIN                                        
01209000       IF (ELTYPE(GTYPTR) NEQ NIL) THEN BEGIN                                       
01209100         LSIZE:=SWORDS(ELTYPE(GTYPTR));                                             
01209200         IF (FORM(ELTYPE(GTYPTR)) = RECORDS) THEN BEGIN                             
01209300           LSP:=RECVAR(ELTYPE(GTYPTR));                                             
01209400         END;                                                                       
01209500       END;                                                                         
01209600     END ELSE BEGIN                                                                 
01209700       ERROR(2870);                                                                 
01209800     END;                                                                           
01209900   END;                                                                             
01210000   WHILE (SYMBOL = COMMA) DO BEGIN                                                  
01210100     INSYMBOL;                                                                      
01210200     CONSTANT((FSYS OR COMMARPARENTSET),LSP1,LVALUE);                               
01210300     VARTS:=VARTS+1;                                                                
01210400     IF (LSP = NIL) THEN BEGIN                                                      
01210500       ERROR(2871);                                                                 
01210600     END ELSE IF (FORM(LSP) NEQ TAGFLD) THEN BEGIN                                  
01210700       ERROR(2872);                                                                 
01210800     END ELSE IF (TAGFIELDP(LSP) NEQ NIL) THEN BEGIN                                
01210900       IF STRING(LSP1) OR (LSP1 = REALPTR) THEN BEGIN                               
01211000         ERROR(2873);                                                               
01211100       END ELSE IF COMPTYPES(IDTYPE(TAGFIELDP(LSP)),LSP1) THEN BEGIN                
01211200         LSP1:=FSTVAR(LSP);                                                         
01211300         WHILE (LSP1 NEQ NIL) DO BEGIN                                              
01211400           IF (VARVAL(LSP1) = LVALUE) THEN BEGIN                                    
01211500             LSIZE:=SWORDS(LSP1); LSP:=SUBVAR(LSP1);                                
01211600             GOTO L1;                                                               
01211700           END ELSE BEGIN                                                           
01211800             LSP1:=NXTVAR(LSP1);                                                    
01211900           END;                                                                     
01212000         END;                                                                       
01212100         LSIZE:=SWORDS(LSP); LSP:=NIL;                                              
01212200       END ELSE BEGIN                                                               
01212300         ERROR(2874);                                                               
01212400       END;                                                                         
01212500     END;                                                                           
01212600 L1:                                                                                
01212700   END; % OF WHILE                                                                  
01212800   GENV(VALC,BASELVL,ADDRHEAPPTR); GENOP(STON);                                     
01212900   GENLIT(LSIZE); GENOP(ADD); GENV(NAMC,BASELVL,ADDRHEAPPTR);                       
01213000   GENOP(STON);                                                                     
01213100   GENLIT(HEAPSIZE); GENOP(LESS);                                                   
01213200   LABELA:=MAKELABEL; GENBR(BRTR,LABELA);                                           
01213300   RUNTIMEERROR(HEAPFULLERROR);                                                     
01213400   GENLABEL(LABELA);                                                                
01213500 END;%% OF NEW PROCEDURE                                                            
01213600                                                                                    
01213700 PROCEDURE PACK;                                                                    
01213800 %         ****                                                                     
01213900 BEGIN                                                                              
01214000   INTEGER LBOUND1,UBOUND1,LCPCW,LAB1,LAB2,PCWPOSN,LBOUND2,UBOUND2;                 
01214100   GENOP(MKST);                                                                     
01214200   GENV(NAMC,1,INTRINSICADDR(PASCALPACKADDR,                                        
01214300       PASCALINTRINSIC(PASCALPACKINTR)));                                           
01214400   VARIABLE(FSYS OR COMMASET);                                                      
01214500   IF(GTYPTR NEQ NIL) THEN BEGIN                                                    
01214600     IF (FORM(GTYPTR)=ARRAYS) THEN BEGIN                                            
01214700       IF(PACKED(GTYPTR)=UNPACKEDSTRUC) THEN BEGIN                                  
01214800         GENV(NAMC,GVLEVEL,GDPLMT);                                                 
01214900         GENOP(LOAD);                                                               
01215000         GETBOUNDS(INXTYPE(GTYPTR),LBOUND1,UBOUND1);                                
01215100         GENLIT(LBOUND1);                                                           
01215200         GENLIT(UBOUND1);                                                           
01215300         GENLIT(GIDPLMT);                                                           
01215400       END ELSE BEGIN                                                               
01215500         ERROR(2881);                                                               
01215600       END;                                                                         
01215700     END ELSE BEGIN                                                                 
01215800       ERROR(2880);                                                                 
01215900     END;                                                                           
01216000   END;                                                                             
01216100   IF(SYMBOL=COMMA) THEN INSYMBOL ELSE ERROR(2882);                                 
01216200   EXPRESSION(FSYS OR COMMASET);                                                    
01216300   LOADV;                                                                           
01216400   IF(SYMBOL=COMMA) THEN INSYMBOL ELSE ERROR(2882);                                 
01216500   LAB1:=MAKELABEL;                                                                 
01216600   GENBR(BRUN,LAB1);                                                                
01216700 %                                                                                  
01216800   LEXLEVEL:=*+1;                                                                   
01216900   LAB2:=MAKELABEL;                                                                 
01217000   GENLABEL(LAB2);                                                                  
01217100   PCWPOSN:=ASKFORPCW(LAB2) & 0[47:1];                                              
01217200   GENOP(MKST);                                                                     
01217300   VARIABLE(FSYS OR RPARENTSET);                                                    
01217400   IF(GTYPTR NEQ NIL) THEN BEGIN                                                    
01217500     IF(FORM(GTYPTR) = ARRAYS) THEN BEGIN                                           
01217600       IF(PACKED(GTYPTR)=PACKEDSTRUC) THEN BEGIN                                    
01217700         IF GCHARDESCR THEN BEGIN                                                   
01217800           LOADADDRESS;                                                             
01217900         END;                                                                       
01218000         GENV(NAMC,GVLEVEL,GDPLMT);                                                 
01218100         IF GCHARDESCR THEN BEGIN                                                   
01218200           MAKECHARDESCR(BITS(GTYPTR));                                             
01218300         END ELSE BEGIN                                                             
01218400           GENOP(LOAD);                                                             
01218500         END;                                                                       
01218600         CASE BITS(GTYPTR) OF BEGIN                                                 
01218700         1: GENV(NAMC,LEXLEVEL,2);                                                  
01218800         4: GENV(NAMC,LEXLEVEL,3);                                                  
01218900         6: GENV(NAMC,LEXLEVEL,4);                                                  
01219000         8: GENV(NAMC,LEXLEVEL,5);                                                  
01219100         48: GENV(NAMC,LEXLEVEL,6);                                                 
01219200         END;                                                                       
01219300         IF GCHARDESCR THEN GENOP(RSDN);                                            
01219400         GENOP(EXCH);                                                               
01219500         GETBOUNDS(INXTYPE(GTYPTR),LBOUND2,UBOUND2);                                
01219600         GENLIT(LBOUND2);                                                           
01219700         IF GCHARDESCR THEN GENOP(EXCH);                                            
01219800         GENLIT(UBOUND2);                                                           
01219900         IF GCHARDESCR THEN GENOP(EXCH);                                            
01220000         IF((UBOUND1-LBOUND1)<(UBOUND2-LBOUND2)) THEN ERROR(2884);                  
01220100         IF NOT GCHARDESCR THEN GENLIT(GIDPLMT);                                    
01220200         IF(AELTYPE(GTYPTR) NEQ NIL) THEN BEGIN                                     
01220300           IF (FORM(AELTYPE(GTYPTR))=SUBRANGE) THEN BEGIN                           
01220400             GENLIT(SMIN(AELTYPE(GTYPTR)));                                         
01220500           END ELSE BEGIN                                                           
01220600             IF (BITS(GTYPTR) NEQ 1) THEN BEGIN                                     
01220700               GENOP(ZERO);                                                         
01220800             END;                                                                   
01220900           END;                                                                     
01221000         END;                                                                       
01221100         GENOP(ENTR);                                                               
01221200         GENOP(EXIT);                                                               
01221300       END ELSE BEGIN                                                               
01221400         ERROR(2883);                                                               
01221500       END;                                                                         
01221600     END ELSE BEGIN                                                                 
01221700       ERROR(2880);                                                                 
01221800     END;                                                                           
01221900   END;                                                                             
01222000   GENERATEPCWWORD(PCWPOSN,NIL);                                                    
01222100   LCPCW:=LC;                                                                       
01222200   LEXLEVEL:=*-1;                                                                   
01222300   LC:=LC+1;                                                                        
01222400   GENLABEL(LAB1);                                                                  
01222500   GENV(NAMC,LEXLEVEL,LCPCW);                                                       
01222600   GENOP(STFF);                                                                     
01222700   GENOP(ENTR);                                                                     
01222800 END;   %OF PACK                                                                    
01222900                                                                                    
01223000 PROCEDURE UNPACK;                                                                  
01223100 %         ******                                                                   
01223200 BEGIN                                                                              
01223300   INTEGER                                                                          
01223400     LBOUND1,UBOUND1,LBOUND2,UBOUND2;                                               
01223500   GENOP(MKST);                                                                     
01223600   VARIABLE(FSYS OR COMMASET);                                                      
01223700   IF(GTYPTR NEQ NIL) THEN BEGIN                                                    
01223800     IF (FORM(GTYPTR) = ARRAYS) THEN BEGIN                                          
01223900       IF(PACKED(GTYPTR)=PACKEDSTRUC) THEN BEGIN                                    
01224000         IF GCHARDESCR THEN BEGIN                                                   
01224100           LOADADDRESS;                                                             
01224200         END;                                                                       
01224300         GENV(NAMC,GVLEVEL,GDPLMT);                                                 
01224400         IF GCHARDESCR THEN BEGIN                                                   
01224500           MAKECHARDESCR(BITS(GTYPTR));                                             
01224600         END ELSE BEGIN                                                             
01224700           GENOP(LOAD);                                                             
01224800         END;                                                                       
01224900         CASE BITS(GTYPTR) OF BEGIN                                                 
01225000         1: GENV(NAMC,1,INTRINSICADDR(PASCALUNPACK1ADDR,                            
01225100              PASCALINTRINSIC(PASCALUNPACK1INTR)));                                 
01225200         4: GENV(NAMC,1,INTRINSICADDR(PASCALUNPACK4ADDR,                            
01225300              PASCALINTRINSIC(PASCALUNPACK4INTR)));                                 
01225400         6: GENV(NAMC,1,INTRINSICADDR(PASCALUNPACK6ADDR,                            
01225500              PASCALINTRINSIC(PASCALUNPACK6INTR)));                                 
01225600         8: GENV(NAMC,1,INTRINSICADDR(PASCALUNPACK8ADDR,                            
01225700              PASCALINTRINSIC(PASCALUNPACK8INTR)));                                 
01225800         48: GENV(NAMC,1,INTRINSICADDR(PASCALUNPACK48ADDR,                          
01225900              PASCALINTRINSIC(PASCALUNPACK48INTR)));                                
01226000         END;   %OF CASE                                                            
01226100         IF GCHARDESCR THEN GENOP(RSDN);                                            
01226200         GENOP(EXCH);                                                               
01226300           GETBOUNDS(INXTYPE(GTYPTR),LBOUND1,UBOUND1);                              
01226400         GENLIT(LBOUND1);                                                           
01226500         IF GCHARDESCR THEN GENOP(EXCH);                                            
01226600         GENLIT(UBOUND1);                                                           
01226700         IF GCHARDESCR THEN GENOP(EXCH);                                            
01226800         IF NOT GCHARDESCR THEN GENLIT(GIDPLMT);                                    
01226900         IF(AELTYPE(GTYPTR) NEQ NIL) THEN BEGIN                                     
01227000           IF (FORM(AELTYPE(GTYPTR))=SUBRANGE) THEN BEGIN                           
01227100             GENLIT(SMIN(AELTYPE(GTYPTR)));                                         
01227200           END ELSE BEGIN                                                           
01227300             IF (BITS(GTYPTR) NEQ 1) THEN BEGIN                                     
01227400               GENOP(ZERO);                                                         
01227500             END;                                                                   
01227600           END;                                                                     
01227700         END;                                                                       
01227800       END ELSE BEGIN                                                               
01227900         ERROR(2883);                                                               
01228000       END;                                                                         
01228100     END ELSE BEGIN                                                                 
01228200       ERROR(2880);                                                                 
01228300     END;                                                                           
01228400   END;                                                                             
01228500   IF(SYMBOL=COMMA) THEN INSYMBOL ELSE ERROR(2882);                                 
01228600   VARIABLE(FSYS OR COMMASET);                                                      
01228700   IF(GTYPTR NEQ NIL) THEN BEGIN                                                    
01228800     IF(FORM(GTYPTR)=ARRAYS) THEN BEGIN                                             
01228900       IF(PACKED(GTYPTR)=UNPACKEDSTRUC) THEN BEGIN                                  
01229000         GENV(NAMC,GVLEVEL,GDPLMT);                                                 
01229100         GENOP(LOAD);                                                               
01229200         GETBOUNDS(INXTYPE(GTYPTR),LBOUND2,UBOUND2);                                
01229300         GENLIT(LBOUND2);                                                           
01229400         GENLIT(UBOUND2);                                                           
01229500         IF((UBOUND1-LBOUND1)>(UBOUND2-LBOUND2)) THEN ERROR(2884);                  
01229600         GENLIT(GIDPLMT);                                                           
01229700       END ELSE BEGIN                                                               
01229800         ERROR(2881);                                                               
01229900       END;                                                                         
01230000     END ELSE BEGIN                                                                 
01230100       ERROR(2880);                                                                 
01230200     END;                                                                           
01230300   END;                                                                             
01230400   IF(SYMBOL=COMMA) THEN INSYMBOL ELSE ERROR(2882);                                 
01230500   EXPRESSION(FSYS OR RPARENTSET);                                                  
01230600   LOADV;                                                                           
01230700   GENOP(ENTR);                                                                     
01230800 END;   %OF UNPACK                                                                  
01230900                                                                                    
01231000 PROCEDURE DISPOSE;                                                                 
01231100 %         *******                                                                  
01231200 BEGIN                                                                              
01231300   IF STANDARDTOG THEN ERROR(1851);                                                 
01231400   VARIABLE(FSYS OR COMMARPARENTSET); LOADIRW;                                      
01231500   GENOP1(LT8,4"1F");  GENOP2(ISOL,9,48);                                           
01231600   GENOP(STOD);                                                                     
01231700   IF (SYMBOL = COMMA) THEN BEGIN                                                   
01231800     DO BEGIN                                                                       
01231900       INSYMBOL;                                                                    
01232000     END UNTIL SYMBOLIN(RPARENTSEMICOLONSET);                                       
01232100     ERROR(1852);                                                                   
01232200   END;                                                                             
01232300 END;   %OF DISPOSE                                                                 
01232400                                                                                    
01232500   %                                                                                
01232600   % HANDLES IN-LINE (INTRINSIC) CALLS AND NON-STANDARD VARIETIES                   
01232700   % ============================================================                   
01232800   LKEY:=KEY(FCP);                                                                  
01232900   IF STANDARDTOG THEN BEGIN                                                        
01233000     IF (PFSTD(FCP) NEQ STDPASCAL) THEN BEGIN                                       
01233100       ERROR(1878);                                                                 
01233200     END;                                                                           
01233300   END;                                                                             
01233400   IF (KLASS(FCP)=PROC AND LKEY=8)                                                  
01233500     OR (KLASS(FCP)=FUNC AND                                                        
01233600       ((LKEY>35 AND LKEY<=39) OR (LKEY=10 OR LKEY=11)))                            
01233700     OR (KLASS(FCP)=PROC AND                                                        
01233800       (LKEY=6 OR LKEY=7 OR LKEY=13 OR LKEY=15 OR LKEY=16 OR LKEY=22 OR             
01233900        LKEY=23))                                                                   
01234000     THEN PARAMS := FALSE                                                           
01234100     ELSE PARAMS := TRUE;                                                           
01234200   IF PARAMS THEN                                                                   
01234300     IF (SYMBOL = LPARENT) THEN INSYMBOL ELSE ERROR(2876);                          
01234400   IF (KLASS(FCP)=PROC) THEN BEGIN                                                  
01234500     CASE LKEY OF BEGIN                                                             
01234600       1:                               % GET                                       
01234700       2:                               % PUT                                       
01234800         GETPUT;                                                                    
01234900       3:                               % NEW                                       
01235000         NEWPROC;                                                                   
01235100       4:                               % MARK                                      
01235200         MARKPROC;                                                                  
01235300       5:                               % RELEASE                                   
01235400         RELEASEPROC;                                                               
01235500       6:                               % READ                                      
01235600       7:                               % WRITE                                     
01235700         READWRITEPROC(LKEY);                                                       
01235800       8:                               % HALT                                      
01235900         HALT;                                                                      
01236000       9:                               % TIMESTAMP                                 
01236100         TIMESTAMP;                                                                 
01236200       10:                              % CLOSE                                     
01236300         CLOSE;                                                                     
01236400       11:                              % SEEK                                      
01236500         SEEK;                                                                      
01236600       12:                              % SPACE                                     
01236700         SPACE;                                                                     
01236800       13:                              % PAGE                                      
01236900         NEWPAGE;                                                                   
01237000       14:                              % STARTJOB                                  
01237100         STARTJOB;                                                                  
01237200       15:                              % READLN                                    
01237300       16:                              % WRITELN                                   
01237400         READWRITEPROC(LKEY);                                                       
01237500       17:                              % RESET                                     
01237600       18:                              % REWRITE                                   
01237700         CLOSE;                                                                     
01237800       19:                              % PACK                                      
01237900         PACK;                                                                      
01238000       20:                              % UNPACK                                    
01238100         UNPACK;                                                                    
01238200       21:                              % DISPOSE                                   
01238300         DISPOSE;                                                                   
01238400       22:                              % READREC                                   
01238500       23:                                                                          
01238600         READWRITEPROC(LKEY);           % WRITEREC                                  
01238700  $SET OMIT = NOT CODETEST                                                          
01238800       24:                                                                          
01238900         CODETEST;                                                                  
01239000  $POP OMIT                                                                         
01239100     END; % OF CASE                                                                 
01239200   END ELSE BEGIN                                                                   
01239300     IF (LKEY < 12) THEN BEGIN                                                      
01239400       IF (LKEY <= 9) THEN BEGIN                                                    
01239500         EXPRESSION(FSYS OR RPARENTSET);                                            
01239600         LOADV;                                                                     
01239700       END;                                                                         
01239800       CASE LKEY OF BEGIN                                                           
01239900         1: ABS;                                                                    
01240000         2: SQR;                                                                    
01240100         3: TRUNC;                                                                  
01240200         4: ROUND;                                                                  
01240300         5: ODD;                                                                    
01240400         6: ORD;                                                                    
01240500         7: CHR;                                                                    
01240600         8:9: PREDSUCC;                                                             
01240700         10: EOF;                                                                   
01240800         11: ENDOFLINE;                                                             
01240900       END; % OF CASE                                                               
01241000     END ELSE BEGIN                                                                 
01241100       CASE (LKEY) OF BEGIN                                                         
01241200       12: INTRINSICCALL(SINADDR,SIN);                                              
01241300       13: INTRINSICCALL(COSADDR,COS);                                              
01241400       14: INTRINSICCALL(ARCTANADDR,ARCTAN);                                        
01241500       15: INTRINSICCALL(EXPADDR,EXP);                                              
01241600       16: INTRINSICCALL(LNADDR,LN);                                                
01241700       17: INTRINSICCALL(SQRTADDR,SQRT);                                            
01241800       18: INTRINSICCALL(TANADDR,TAN);                                              
01241900       19: INTRINSICCALL(COTANADDR,COTAN);                                          
01242000       20: INTRINSICCALL(ARCSINADDR,ARCSIN);                                        
01242100       21: INTRINSICCALL(ARCCOSADDR,ARCCOS);                                        
01242200       22: INTRINSICCALL(ARCTAN2ADDR,ARCTAN2);                                      
01242300       23: INTRINSICCALL(SINHADDR,SINH);                                            
01242400       24: INTRINSICCALL(COSHADDR,COSH);                                            
01242500       25: INTRINSICCALL(TANHADDR,TANH);                                            
01242600       26: INTRINSICCALL(ATANHADDR,ATANH);                                          
01242700       27: INTRINSICCALL(LOGADDR,LOG);                                              
01242800       28: INTRINSICCALL(ERFADDR,ERF);                                              
01242900       29: INTRINSICCALL(ERFCADDR,ERFC);                                            
01243000       30: INTRINSICCALL(GAMMAADDR,GAMMA);                                          
01243100       31: INTRINSICCALL(LNGAMMAADDR,LNGAMMA);                                      
01243200       32: CARDCALL;                                                                
01243300       33: RANDOM;                                                                  
01243400       34:                                                                          
01243500       35: MAXMIN;                                                                  
01243600       36: TIMECALL(11);                                                            
01243700       37: TIMECALL(12);                                                            
01243800       38: TIMECALL(13);                                                            
01243900       39: ENDOFFILE;                                                               
01244000       END;  %OF CASE                                                               
01244100     END;                                                                           
01244200     GKIND:=EXPR;                                                                   
01244300   END;                                                                             
01244400   IF PARAMS THEN                                                                   
01244500     IF (SYMBOL = RPARENT) THEN INSYMBOL ELSE ERROR(2877);                          
01244600 END; % OF CALL STANDARD                                                            
01244700                                                                                    
01244800                                                                                    
01244900 PROCEDURE CALLNONSTANDARD(FSYS,FCP);                                               
01245000 %         ***************                                                          
01245100 VALUE FSYS,FCP;                                                                    
01245200 TYPESETOFSYS FSYS;                                                                 
01245300 TYPEIDENTPTR FCP;                                                                  
01245400 %   ACTUAL = VALUE PARAMETER,   FORMAL = VAR PARAMETER                             
01245500 BEGIN                                                                              
01245600   TYPEIDENTPTR NXT,LIP,LCP;                                                        
01245700   TYPESTRUCTPTR LSP;                                                               
01245800   TYPEIDKIND LKIND;                                                                
01245900   INTEGER LAB;                                                                     
01246000   BOOLEAN LB;                                                                      
01246100                                                                                    
01246200   BOOLEAN PROCEDURE COMPPROCS(FACT,FORML);                                         
01246300   %                 *********                                                      
01246400   VALUE FACT,FORML;                                                                
01246500   TYPEIDENTPTR FACT,FORML;                                                         
01246600   BEGIN                                                                            
01246700   TYPEIDENTPTR LCP1,LCP2;                                                          
01246800   BOOLEAN COMP;                                                                    
01246900   IF (FACT=NIL) OR (FORML=NIL) THEN BEGIN                                          
01247000     COMPPROCS:=TRUE;                                                               
01247100   END ELSE BEGIN                                                                   
01247200     IF (FACT=FORML) THEN BEGIN                                                     
01247300       COMPPROCS:=TRUE;                                                             
01247400     END ELSE BEGIN                                                                 
01247500       LCP1:=NEXT(FACT);                                                            
01247600       LCP2:=FPARAMLIST(FORML);                                                     
01247700       COMP:=TRUE;                                                                  
01247800       WHILE (LCP1 NEQ NIL) AND (LCP2 NEQ NIL) DO BEGIN                             
01247900         IF (KLASS(LCP1)=KLASS(LCP2)) THEN BEGIN                                    
01248000           IF (INTEST(KLASS(LCP1),PROCFUNCSET)) THEN BEGIN                          
01248100             COMP:=COMP AND COMPPROCS(LCP1,LCP2);                                   
01248200             IF (KLASS(LCP1)=FUNC) THEN BEGIN                                       
01248300               COMP:=COMP AND IDENTCOMPTYPES(LCP1,LCP2);                            
01248400             END;                                                                   
01248500           END ELSE BEGIN                                                           
01248600             COMP:=IDENTCOMPTYPES(IDTYPE(LCP1),IDTYPE(LCP2))                        
01248700                     AND (VKIND(LCP1) = VKIND(LCP2)) AND COMP;                      
01248800           END;                                                                     
01248900         END ELSE BEGIN                                                             
01249000           COMP:=FALSE;                                                             
01249100         END;                                                                       
01249200         LCP1:=NEXT(LCP1);  LCP2:=NEXT(LCP2);                                       
01249300       END;                                                                         
01249400       IF (KLASS(FORML)=FUNC) THEN BEGIN                                            
01249500         COMP:=COMP AND IDENTCOMPTYPES(IDTYPE(FACT),IDTYPE(FORML));                 
01249600       END;                                                                         
01249700       COMPPROCS:= COMP AND (LCP1=LCP2);                                            
01249800     END;                                                                           
01249900   END;                                                                             
01250000   END;   %OF COMPPROCS                                                             
01250100                                                                                    
01250200   %                                                                                
01250300   LKIND:=PFKIND(FCP);                                                              
01250400   IF (LKIND=ACTUAL) THEN BEGIN                                                     
01250500     NXT:=NEXT(FCP);                                                                
01250600   END ELSE BEGIN                                                                   
01250700     NXT:=FPARAMLIST(FCP);                                                          
01250800   END;                                                                             
01250900   GENOP(MKST); GENV(NAMC,PFLEV(FCP),PFDPLMT(FCP));                                 
01251000   IF (SYMBOL = LPARENT) THEN BEGIN                                                 
01251100     DO BEGIN                                                                       
01251200       LB:=FALSE;                                                                   
01251300       IF (NXT = NIL) THEN BEGIN                                                    
01251400         ERROR(2470);                                                               
01251500       END ELSE BEGIN                                                               
01251600         LB:=INTEST(KLASS(NXT),PRCFNCSET);                                          
01251700       END;                                                                         
01251800       INSYMBOL;                                                                    
01251900       IF LB THEN BEGIN                                                             
01252000         IF (SYMBOL NEQ IDENT) THEN BEGIN                                           
01252100           ERROR(2473); SKIP(FSYS OR COMMARPARENTSET);                              
01252200         END ELSE BEGIN                                                             
01252300           IF (KLASS(NXT) = PROC) THEN BEGIN                                        
01252400             SEARCHID(PRCSET,LIP);                                                  
01252500           END ELSE BEGIN                                                           
01252600             SEARCHID(FNCSET,LIP);                                                  
01252700           END;                                                                     
01252800           IF (PFDECLKIND(LIP)=STANDARD) THEN BEGIN                                 
01252900             IF (FPROCPARAM(LIP)=INLINECODE) THEN BEGIN                             
01253000               ERROR(2466);    %IN LINE CODE                                        
01253100             END;                                                                   
01253200           END;                                                                     
01253300           IF NOT COMPPROCS(LIP,NXT) THEN ERROR(2467);  %PROCS NOT COMPAT           
01253400           IF (PFDECLKIND(LIP)=STANDARD) THEN BEGIN                                 
01253500             IF (FPROCPARAM(LIP)=PASSPROC) THEN BEGIN                               
01253600               CASE KEY(LIP) OF BEGIN                                               
01253700               12: GENV(NAMC,1,INTRINSICADDR(SINADDR,SIN));                         
01253800               13: GENV(NAMC,1,INTRINSICADDR(COSADDR,COS));                         
01253900               14: GENV(NAMC,1,INTRINSICADDR(ARCTANADDR,ARCTAN));                   
01254000               15: GENV(NAMC,1,INTRINSICADDR(EXPADDR,EXP));                         
01254100               16: GENV(NAMC,1,INTRINSICADDR(LNADDR,LN));                           
01254200               17: GENV(NAMC,1,INTRINSICADDR(SQRTADDR,SQRT));                       
01254300               18: GENV(NAMC,1,INTRINSICADDR(TANADDR,TAN));                         
01254400               19: GENV(NAMC,1,INTRINSICADDR(COTANADDR,COTAN));                     
01254500               20: GENV(NAMC,1,INTRINSICADDR(ARCSINADDR,ARCSIN));                   
01254600               21: GENV(NAMC,1,INTRINSICADDR(ARCCOSADDR,ARCCOS));                   
01254700               22: GENV(NAMC,1,INTRINSICADDR(ARCTAN2ADDR,ARCTAN2));                 
01254800               23: GENV(NAMC,1,INTRINSICADDR(SINHADDR,SINH));                       
01254900               24: GENV(NAMC,1,INTRINSICADDR(COSHADDR,COSH));                       
01255000               25: GENV(NAMC,1,INTRINSICADDR(TANHADDR,TANH));                       
01255100               26: GENV(NAMC,1,INTRINSICADDR(ATANHADDR,ATANH));                     
01255200               27: GENV(NAMC,1,INTRINSICADDR(LOGADDR,LOG));                         
01255300               28: GENV(NAMC,1,INTRINSICADDR(ERFADDR,ERF));                         
01255400               29: GENV(NAMC,1,INTRINSICADDR(ERFCADDR,ERFC));                       
01255500               30: GENV(NAMC,1,INTRINSICADDR(GAMMAADDR,GAMMA));                     
01255600               31: GENV(NAMC,1,INTRINSICADDR(LNGAMMAADDR,LNGAMMA));                 
01255700               33: GENV(NAMC,1,INTRINSICADDR(RANDOMADDR,RANDOMINTR));               
01255800               END;                                                                 
01255900             END;                                                                   
01256000             GENOP(STFF);                                                           
01256100           END ELSE BEGIN                                                           
01256200             GENV(NAMC,PFLEV(LIP),PFDPLMT(LIP));                                    
01256300             IF (PFKIND(LIP)=FORMAL) THEN BEGIN                                     
01256400               GENOP(LOAD);                                                         
01256500             END ELSE BEGIN                                                         
01256600               GENOP(STFF);                                                         
01256700             END;                                                                   
01256800           END;                                                                     
01256900         END;                                                                       
01257000         INSYMBOL;                                                                  
01257100         CHECKIN((FSYS OR COMMARPARENTSET),2475);                                   
01257200       END ELSE BEGIN                                                               
01257300         IF (VKIND(NXT)=FORMAL) THEN BEGIN                                          
01257400           IF (SYMBOL=IDENT) THEN BEGIN                                             
01257500             SEARCHID(KONSTVARFLDFNCSET,LCP);                                       
01257600             IF (LCP NEQ NIL) THEN BEGIN                                            
01257700               IF (VFORCONTRL(LCP)=REAL(TRUE)) THEN BEGIN                           
01257800                 ERROR(1480);                                                       
01257900               END;                                                                 
01258000               IF (KLASS(LCP)=FIELD) THEN BEGIN                                     
01258100                 IF(PACKEDFIELD(LCP)=PACKEDSTRUC) THEN BEGIN                        
01258200                   IF(BITRANGE(LCP) NEQ BITSPERWORD) THEN BEGIN                     
01258300                     ERROR(2469);                                                   
01258400                   END;                                                             
01258500                 END;                                                               
01258600               END;                                                                 
01258700             END;                                                                   
01258800             IF (INTEST(KLASS(LCP),VARFLDSET)) THEN BEGIN                           
01258900               INSYMBOL;                                                            
01259000               SELECTOR(FSYS OR COMMARPARENTSET,LCP);                               
01259100             END ELSE BEGIN                                                         
01259200               EXPRESSION(FSYS OR COMMARPARENTSET);                                 
01259300             END;                                                                   
01259400             IF (GPACKEDSUBRFIELD OR GPACKEDARRAY) THEN BEGIN                       
01259500               IF (GCHARSIZE NEQ BITSPERWORD) THEN BEGIN                            
01259600                 ERROR(2469);                                                       
01259700               END;                                                                 
01259800             END;                                                                   
01259900           END ELSE BEGIN                                                           
01260000             ERROR(2478);                                                           
01260100           END;                                                                     
01260200         END ELSE BEGIN                                                             
01260300           EXPRESSION(FSYS OR COMMARPARENTSET);                                     
01260400         END;                                                                       
01260500         IF (GTYPTR NEQ NIL) THEN BEGIN                                             
01260600           IF (NXT NEQ NIL) THEN BEGIN                                              
01260700             LSP:=IDTYPE(NXT);                                                      
01260800             IF (LSP NEQ NIL) THEN BEGIN                                            
01260900               IF (VKIND(NXT) = ACTUAL) THEN BEGIN                                  
01261000  $SET OMIT = NAMECOMP                                                              
01261100                 IF(COMPTYPES(REALPTR,LSP) AND (GTYPTR=INTPTR))THEN BEGIN           
01261200                   GTYPTR := REALPTR;                                               
01261300                 END;                                                               
01261400  $POP OMIT                                                                         
01261500                 IF (FORM(LSP) < POWER) OR SHORTSET(LSP) THEN BEGIN                 
01261600                   LOADV;                                                           
01261700                   IF COMPTYPES(LSP,INTPTR) THEN GENOP(NTGR);                       
01261800                   IF (FORM(LSP)=SUBRANGE) THEN BEGIN                               
01261900                     RANGECHECK(SMIN(LSP),SMAX(LSP),GBMIN,GBMAX);                   
01262000                   END;                                                             
01262100                   IF SHORTSET(LSP) THEN BEGIN                                      
01262200                     IF BOUNDSCHECKTOG THEN BEGIN                                   
01262300                       GETBOUNDS(ELSET(LSP),GBMIN,GBMAX);                           
01262400                       IF(GBMIN NEQ 0) OR (GBMAX NEQ 47) THEN BEGIN                 
01262500                         GENOP(DUPL);                                               
01262600                         GENOP(ZERO);                                               
01262700                         GENOP2(INSR,GBMAX,GBMAX-GBMIN+1);                          
01262800                         GENOP(ZERO);                                               
01262900                         GENOP(SAME);                                               
01263000                         LAB:=MAKELABEL;                                            
01263100                         GENBR(BRTR,LAB);                                           
01263200                         RUNTIMEERROR(BOUNDSERROR);                                 
01263300                         GENLABEL(LAB);                                             
01263400                       END;                                                         
01263500                     END;                                                           
01263600                   END;                                                             
01263700                 END ELSE BEGIN                                                     
01263800                   %VALUE RECORD OR ARRAY                                           
01263900                   IF(FORM(LSP)=ARRAYS) THEN BEGIN                                  
01264000                     CASE BITS(LSP) OF BEGIN                                        
01264100                     1: 8: 48: LOADSTRINGDESCRIPTOR;                                
01264200                     4: LOADINXDDESCRIPTOR;                                         
01264300                        GENOP1(BSET,41);                                            
01264400                     6: LOADINXDDESCRIPTOR;                                         
01264500                        GENOP1(LT8,3);                                              
01264600                        GENOP2(INSR,41,2);                                          
01264700                     END;                                                           
01264800                   END ELSE BEGIN                                                   
01264900                     LOADSTRINGDESCRIPTOR;                                          
01265000                   END;                                                             
01265100                   IF (BINDIN(FCP) NEQ BINDITIN) THEN BEGIN                         
01265200                     GENOP(DUPL);                                                   
01265300                   END;                                                             
01265400                 END;                                                               
01265500  $SET OMIT = NOT NAMECOMP                                                          
01265600                 IF NOT ASSCOMPTYPES(LSP,GTYPTR) THEN BEGIN                         
01265700                   ERROR(2479);                                                     
01265800                 END;                                                               
01265900  $POP OMIT                                                                         
01266000               END ELSE BEGIN                                                       
01266100                 IF (GKIND=VARBL) AND NOT(STRING(GTYPTR) AND (GVLEVEL=1))           
01266200                   THEN BEGIN                                                       
01266300                   IF(FORM(LSP) = FILES) THEN BEGIN                                 
01266400                     GENV(NAMC,GVLEVEL,GDPLMT);                                     
01266500                     GENOP(STFF);                                                   
01266600                     IF(BINDIN(FCP)=DONTBIND) THEN BEGIN                            
01266700                       GENV(NAMC,GVLEVEL,GDPLMT+1);                                 
01266800                       GENOP(LOAD);                                                 
01266900                       GENV(NAMC,GVLEVEL,GDPLMT+2);                                 
01267000                       GENOP(LOAD);                                                 
01267100                     END;                                                           
01267200                   END ELSE BEGIN                                                   
01267300                     LOADIRW;                                                       
01267400                     IF(BINDIN(FCP) = BINDITIN) THEN BEGIN                          
01267500                       IF(FORM(LSP)=ARRAYS) OR (FORM(LSP)=RECORDS)                  
01267600                         OR LONGSET(LSP) THEN BEGIN                                 
01267700                         GENOP(EXCH);                                               
01267800                       END;                                                         
01267900                     END;                                                           
01268000                   END;                                                             
01268100                 END ELSE BEGIN                                                     
01268200                   ERROR(2478);                                                     
01268300                 END;                                                               
01268400  $SET OMIT = NOT NAMECOMP                                                          
01268500                 IF NOT IDENTCOMPTYPES(LSP,GTYPTR) THEN ERROR(2471);                
01268600  $POP OMIT                                                                         
01268700               END;                                                                 
01268800  $SET OMIT = NAMECOMP                                                              
01268900               IF NOT COMPTYPES(LSP,GTYPTR) THEN ERROR(2479);                       
01269000  $POP OMIT                                                                         
01269100             END;                                                                   
01269200           END;                                                                     
01269300         END;                                                                       
01269400       END;                                                                         
01269500       IF (NXT NEQ NIL) THEN NXT:=NEXT(NXT);                                        
01269600     END UNTIL (SYMBOL NEQ COMMA);                                                  
01269700     IF (SYMBOL = RPARENT) THEN INSYMBOL ELSE ERROR(2476);                          
01269800   END;                                                                             
01269900   IF (LKIND = ACTUAL) THEN BEGIN                                                   
01270000     IF (NXT NEQ NIL) THEN ERROR(2477);                                             
01270100   END;                                                                             
01270200   IF STATISTICSFLAG THEN BEGIN                                                     
01270300     % DON'T COUNT TIME IN CALLEE                                                   
01270400     STATISTICSCODE(1,SDISP);                                                       
01270500     GENOP(ENTR);                                                                   
01270600     STATISTICSCODE(2,SDISP);                                                       
01270700   END ELSE BEGIN                                                                   
01270800     GENOP(ENTR);                                                                   
01270900   END;                                                                             
01271000   GTYPTR:=IDTYPE(FCP);                                                             
01271100 END; % OF CALL NON-STANDARD PROCEDURE/FUNCTION                                     
01271200                                                                                    
01271300                                                                                    
01271400                                                                                    
01271500                                                                                    
01271600 PROCEDURE EXPRESSION(FSYS);                                                        
01271700 %         **********                                                               
01271800 VALUE FSYS;                                                                        
01271900 TYPESETOFSYS FSYS;                                                                 
01272000 BEGIN                                                                              
01272100   DECLARELATTR;                                                                    
01272200   TYPEOPERATOR LOP;                                                                
01272300   INTEGER LSIZE,LBITS;                                                             
01272400   BOOLEAN TEMPONSTACK;                                                             
01272500                                                                                    
01272600                                                                                    
01272700 PROCEDURE SIMPLEEXPRESSION(FSYS);                                                  
01272800 %         ***************                                                          
01272900 VALUE FSYS;                                                                        
01273000 TYPESETOFSYS FSYS;                                                                 
01273100 BEGIN                                                                              
01273200   DECLARELATTR;                                                                    
01273300   TYPEOPERATOR LOP;                                                                
01273400   BOOLEAN SIGNED,SIGNTHERE;                                                        
01273500           TYPEIDENTPTR LIP;                                                        
01273600                                                                                    
01273700   DEFINE SETTEMPONSTACK = BEGIN                                                    
01273800     IF NOT TEMPONSTACK THEN BEGIN                                                  
01273900       WHILE (DECLAREDLC < LCMAX) DO BEGIN                                          
01274000         NEWTEMPVAR(LIP);                                                           
01274100         VLEV(LIP):=LEXLEVEL;  VADDR(LIP):=DECLAREDLC;                              
01274200         GENERATEONEWORD(LIP);                                                      
01274300         DECLAREDLC:=*+1;                                                           
01274400       END;                                                                         
01274500       NEWTEMPSET(LIP);                                                             
01274600       VLEV(LIP):=LEXLEVEL;  VADDR(LIP):=LCMAX;                                     
01274700       GENERATEARRAYDESCRIPTOR(SWORDS(GTYPTR),LIP);                                 
01274800       LC:=LCMAX;  LCMAX:=*+1;  DECLAREDLC:=LCMAX;                                  
01274900       LOADSTRINGDESCRIPTOR;                                                        
01275000       TEMPONSTACK:=TRUE;                                                           
01275100       GDPLMT:=LC;  LC:=*+1;                                                        
01275200       GVLEVEL:=LEXLEVEL;  GIDPLMT:=0;  GACCESS:=INDRCT;                            
01275300       LOADSTRINGDESCRIPTOR;                                                        
01275400       GENOP(EXCH);                                                                 
01275500       GENLIT(SWORDS(GTYPTR));                                                      
01275600       GENOP(TWSD);                                                                 
01275700     END;                                                                           
01275800   END;#;                                                                           
01275900                                                                                    
01276000                                                                                    
01276100 PROCEDURE TERM(FSYS);                                                              
01276200 %         ****                                                                     
01276300 VALUE FSYS;                                                                        
01276400 TYPESETOFSYS FSYS;                                                                 
01276500 BEGIN                                                                              
01276600   DECLARELATTR;                                                                    
01276700   TYPEOPERATOR LOP;                                                                
01276800                                                                                    
01276900                                                                                    
01277000 PROCEDURE FACTOR(FSYS);                                                            
01277100 %         ******                                                                   
01277200 VALUE FSYS;                                                                        
01277300 TYPESETOFSYS FSYS;                                                                 
01277400 BEGIN                                                                              
01277500   TYPEIDENTPTR LCP;                                                                
01277600   TYPESTRUCTPTR LSP,LSP1,LRP;                                                      
01277700   BOOLEAN VARPART,CSTPART,GENARRAYDESCR;                                           
01277800   INTEGER MAXBOUND,LMIN,LMAX,LSIZE,LAB1,LAB2,FSETSIZE,LWORD,LBIT;                  
01277900   REAL SAVEGCVAL;                                                                  
01278000   DECLARELATTR;                                                                    
01278100                                                                                    
01278200   PROCEDURE CHECKLIMIT(V,FMIN,FMAX);                                               
01278300   %         **********                                                             
01278400   VALUE FMIN,FMAX;                                                                 
01278500   INTEGER V,FMIN,FMAX;                                                             
01278600   BEGIN                                                                            
01278700     IF (V>FMAX) OR (V<FMIN) THEN BEGIN                                             
01278800       ERROR(2837);                                                                 
01278900       V:=0;                                                                        
01279000     END ELSE BEGIN                                                                 
01279100       SMIN(LRP):=MIN(SMIN(LRP),FMIN);                                              
01279200       SMAX(LRP):=MAX(SMAX(LRP),GCVAL);                                             
01279300     END;                                                                           
01279400   END; % OF CHECKERRORLIMIT                                                        
01279500                                                                                    
01279600   DEFINE SETSUBRBOUNDS(LBMIN,LBMAX) = BEGIN                                        
01279700     IF (GTYPTR = INTPTR) THEN BEGIN                                                
01279800       SMIN(LRP):=MIN(SMIN(LRP),0);                                                 
01279900       SMAX(LRP):=MAX(SMAX(LRP),LBMAX);                                             
01280000     END ELSE BEGIN                                                                 
01280100       SMIN(LRP):=MIN(SMIN(LRP),LBMIN);                                             
01280200       SMAX(LRP):=MAX(SMAX(LRP),LBMAX);                                             
01280300     END;                                                                           
01280400   END;#,                                                                           
01280500                                                                                    
01280600   ZEROTEMP = BEGIN                                                                 
01280700     LOADSTRINGDESCRIPTOR;                                                          
01280800     GENOP(ZERO);  GENLIT((FSETSIZE+BITSPERWORD-1) DIV BITSPERWORD);                
01280900     GENOP(TWSD);                                                                   
01281000   END;#;                                                                           
01281100                                                                                    
01281200                                                                                    
01281300   PROCEDURE PROCESSSUBRANGEINSET;                                                  
01281400   %         ********************                                                   
01281500   BEGIN                                                                            
01281600     INTEGER SAVEGCVAL,LAB1,LAB2;                                                   
01281700     TYPEIDENTPTR LIP;                                                              
01281800     %                                                                              
01281900     SAVEGCVAL:=GCVAL;                                                              
01282000     RANGETYPE(LRP):=GTYPTR;                                                        
01282100     INSYMBOL;                                                                      
01282200     EXPRESSION(FSYS OR COMMARBRACKSET);                                            
01282300     IF (GTYPTR NEQ NIL) THEN BEGIN                                                 
01282400       IF (FORM(GTYPTR) > SUBRANGE) THEN BEGIN                                      
01282500         ERROR(2833); GTYPTR:=NIL;                                                  
01282600  $SET OMIT = NOT NAMECOMP                                                          
01282700       END ELSE IF IDENTCOMPTYPES(RANGETYPE(LRP),GTYPTR) THEN BEGIN                 
01282800  $POP OMIT                                                                         
01282900  $SET OMIT =  NAMECOMP                                                             
01283000       END ELSE IF COMPTYPES(RANGETYPE(LRP),GTYPTR) THEN BEGIN                      
01283100  $POP OMIT                                                                         
01283200         IF (GKIND=CST) THEN BEGIN                                                  
01283300           CHECKLIMIT(GCVAL,LMIN,LMAX);                                             
01283400           IF (GCVAL < SAVEGCVAL) THEN BEGIN                                        
01283500             ERROR(1801);        % WARNING, BOUNDS WRONG WAY                        
01283600             IF (MAXSETSIZE>BITSPERWORD-1) THEN BEGIN                               
01283700               IF NOT GENARRAYDESCR THEN BEGIN                                      
01283800                 IF (GTYPTR=CHARPTR) THEN BEGIN                                     
01283900                   SETTYPE(LSP):=LSET;                                              
01284000                 END ELSE BEGIN                                                     
01284100                   IF(FORM(GTYPTR)=SCALAR) THEN BEGIN                               
01284200                     IF (SCALKIND(GTYPTR)=DECLARED) THEN BEGIN                      
01284300                       IF (VALUES(FCONST(GTYPTR))>BITSPERWORD-1)                    
01284400                       THEN BEGIN                                                   
01284500                         SETTYPE(LSP):=LSET;                                        
01284600                       END;                                                         
01284700                     END;                                                           
01284800                   END;                                                             
01284900                 END;                                                               
01285000                 WHILE (DECLAREDLC < LCMAX) DO BEGIN                                
01285100                   NEWTEMPVAR(LIP);                                                 
01285200                   VLEV(LIP):=LEXLEVEL;  VADDR(LIP):=DECLAREDLC;                    
01285300                   GENERATEONEWORD(LIP);                                            
01285400                   DECLAREDLC:=*+1;                                                 
01285500                 END;                                                               
01285600                 LC:=LCMAX;  LCMAX:=*+1;  DECLAREDLC:=LCMAX;                        
01285700                 GIDPLMT:=0;  GCHARDESCR:= FALSE;  GACCESS:=INDRCT;                 
01285800                 GVLEVEL:=LEXLEVEL;  GDPLMT:=LC;  LC:=*+1;                          
01285900                 GKIND:=VARBL;  GENARRAYDESCR:=TRUE;                                
01286000                 ZEROTEMP;                                                          
01286100                 RANGETYPE(LRP):=GTYPTR;                                            
01286200                 SWORDS(LSP):=0;                                                    
01286300                 GTYPTR := LSP;                                                     
01286400                 COPYLATTRGATTR;                                                    
01286500                 TEMPONSTACK:=TRUE;                                                 
01286600                 GTYPTR := RANGETYPE(LRP);                                          
01286700               END;                                                                 
01286800             END ELSE BEGIN                                                         
01286900               GCVAL:=0;    %THE EMPTY SET                                          
01287000             END;                                                                   
01287100           END ELSE BEGIN                                                           
01287200             IF (LMIN>=0) AND (LMAX<=47) THEN BEGIN                                 
01287300               CSTPART:=CSTPART                                                     
01287400                 & (NOT FALSE)     [GCVAL:(GCVAL-SAVEGCVAL+1)];                     
01287500             END ELSE BEGIN                                                         
01287600               IF NOT GENARRAYDESCR THEN BEGIN                                      
01287700                 IF (GTYPTR=CHARPTR) THEN BEGIN                                     
01287800                   SETTYPE(LSP):=LSET;                                              
01287900                 END ELSE BEGIN                                                     
01288000                   IF(FORM(GTYPTR)=SCALAR) THEN BEGIN                               
01288100                     IF (SCALKIND(GTYPTR)=DECLARED) THEN BEGIN                      
01288200                       IF (VALUES(FCONST(GTYPTR))>BITSPERWORD-1)                    
01288300                       THEN BEGIN                                                   
01288400                         SETTYPE(LSP):=LSET;                                        
01288500                       END;                                                         
01288600                     END;                                                           
01288700                   END;                                                             
01288800                 END;                                                               
01288900                 WHILE (DECLAREDLC < LCMAX) DO BEGIN                                
01289000                   NEWTEMPVAR(LIP);                                                 
01289100                   VLEV(LIP):=LEXLEVEL;  VADDR(LIP):=DECLAREDLC;                    
01289200                   GENERATEONEWORD(LIP);                                            
01289300                   DECLAREDLC:=*+1;                                                 
01289400                 END;                                                               
01289500                 LC:=LCMAX;  LCMAX:=*+1;  DECLAREDLC:=LCMAX;                        
01289600                 GIDPLMT:=0;  GCHARDESCR:= FALSE;  GACCESS:=INDRCT;                 
01289700                 GVLEVEL:=LEXLEVEL;  GDPLMT:=LC;  LC:=*+1;                          
01289800                 GKIND:=VARBL;  GENARRAYDESCR:=TRUE;                                
01289900                 ZEROTEMP;                                                          
01290000                 RANGETYPE(LRP):=GTYPTR;                                            
01290100                 GTYPTR:=LSP;  SWORDS(LSP):=0;                                      
01290200                 COPYLATTRGATTR;                                                    
01290300                 TEMPONSTACK:=TRUE;                                                 
01290400               END;                                                                 
01290500               GENOP(MKST);                                                         
01290600               GENV(NAMC,1,INTRINSICADDR(PASCALLONGSETBITSADDR,                     
01290700                    PASCALINTRINSIC(PASCALLONGSETBITSINTR)));                       
01290800               GENLIT(SAVEGCVAL);                                                   
01290900               GENLIT(GCVAL);                                                       
01291000               COPYGATTRLATTR;                                                      
01291100               LOADIRW;                                                             
01291200               GTYPTR:=RANGETYPE(LRP);                                              
01291300               GENLIT(LMIN);                                                        
01291400               GENLIT(LMAX);                                                        
01291500               GENOP(ENTR);                                                         
01291600             END;                                                                   
01291700           END;                                                                     
01291800         END ELSE BEGIN                                                             
01291900           LOADV;                                                                   
01292000           SETSUBRBOUNDS(0,IF(GTYPTR=INTPTR) THEN MAXSETSIZE ELSE GBMAX);           
01292100           IF (LMIN>=0) AND (LMAX<=47) THEN BEGIN                                   
01292200             GENOP(DUPL);                                                           
01292300             GENLIT(SAVEGCVAL);                                                     
01292400             GENOP(LESS);                                                           
01292500             LAB1:=MAKELABEL;  LAB2:=MAKELABEL;                                     
01292600             GENBR(BRFL,LAB1);                                                      
01292700             GENOP(DLET);                                                           
01292800             IF VARPART THEN GENOP(DLET);                                           
01292900             GENBR(BRUN,LAB2);                                                      
01293000             GENLABEL(LAB1);                                                        
01293100             GENOP(DUPL);                                                           
01293200             IF NOT VARPART THEN BEGIN                                              
01293300               GENOP(ZERO);                                                         
01293400               VARPART := TRUE;                                                     
01293500             END ELSE BEGIN                                                         
01293600               GENOP(RSUP);                                                         
01293700             END;                                                                   
01293800             GENOP(EXCH);                                                           
01293900             IF (SAVEGCVAL>0) THEN BEGIN                                            
01294000               GENLIT(SAVEGCVAL-1);                                                 
01294100               GENOP(SUBT);                                                         
01294200             END ELSE BEGIN                                                         
01294300               GENOP(DUPL);                                                         
01294400               GENOP(ONE);                                                          
01294500               GENOP(ADD);                                                          
01294600             END;                                                                   
01294700             GENOP(EXCH);                                                           
01294800             GENOP(ZERO);                                                           
01294900             GENOP(LNOT);                                                           
01295000             GENOP(DINS);                                                           
01295100             GENLABEL(LAB2);                                                        
01295200           END ELSE BEGIN                                                           
01295300             GENV(NAMC,1,INTRINSICADDR(PASCALLONGSETBITSADDR,                       
01295400               PASCALINTRINSIC(PASCALLONGSETBITSINTR)));                            
01295500             GENOP(EXCH);                                                           
01295600             GENOP(IMKS);                                                           
01295700             GENLIT(SAVEGCVAL);                                                     
01295800             GENOP(EXCH);                                                           
01295900             IF (RANGETYPE(LRP)=NIL) THEN BEGIN                                     
01296000               GENARRAYDESCR:=TRUE;                                                 
01296100               IF (GTYPTR=CHARPTR) THEN BEGIN                                       
01296200                 SETTYPE(LSP):=LSET;                                                
01296300               END ELSE BEGIN                                                       
01296400                 IF(FORM(GTYPTR)=SCALAR) THEN BEGIN                                 
01296500                   IF (SCALKIND(GTYPTR)=DECLARED) THEN BEGIN                        
01296600                     IF (VALUES(FCONST(GTYPTR))>BITSPERWORD-1)                      
01296700                     THEN BEGIN                                                     
01296800                       SETTYPE(LSP):=LSET;                                          
01296900                     END;                                                           
01297000                   END;                                                             
01297100                 END;                                                               
01297200               END;                                                                 
01297300               RANGETYPE(LRP):=GTYPTR;                                              
01297400               WHILE (DECLAREDLC < LCMAX) DO BEGIN                                  
01297500                 NEWTEMPVAR(LIP);                                                   
01297600                 VLEV(LIP):=LEXLEVEL;  VADDR(LIP):=DECLAREDLC;                      
01297700                 GENERATEONEWORD(LIP);                                              
01297800                 DECLAREDLC:=*+1;                                                   
01297900               END;                                                                 
01298000               LC:=LCMAX; LCMAX:=*+1;                                               
01298100               DECLAREDLC:=LCMAX;                                                   
01298200               GTYPTR:=LSP;  SWORDS(LSP):=0;                                        
01298300               GKIND:=VARBL;                                                        
01298400               GIDPLMT:=0;  GCHARDESCR:=FALSE;  GACCESS:=INDRCT;                    
01298500               GVLEVEL:=LEXLEVEL;  GDPLMT:=LC;  LC:=LC+1;                           
01298600               ZEROTEMP;                                                            
01298700               COPYLATTRGATTR;                                                      
01298800               TEMPONSTACK:=TRUE;                                                   
01298900             END ELSE BEGIN                                                         
01299000               COPYGATTRLATTR;                                                      
01299100             END;                                                                   
01299200             LOADIRW;                                                               
01299300             GENLIT(LMIN);                                                          
01299400             GTYPTR := RANGETYPE(LRP);                                              
01299500             GENLIT(LMAX);                                                          
01299600             GENOP(ENTR);                                                           
01299700           END;                                                                     
01299800         END;                                                                       
01299900       END ELSE BEGIN                                                               
01300000         ERROR(2834);                                                               
01300100       END;                                                                         
01300200     END; % OF IF NIL                                                               
01300300   END; % OF PROCESS SUBRANGE IN SET                                                
01300400                                                                                    
01300500   % BODY OF PROCEDURE FACTOR                                                       
01300600   %                                                                                
01300700   IF NOT SYMBOLIN(FACBEGSYS) THEN BEGIN                                            
01300800     ERROR(2830); SKIP(FSYS OR FACBEGSYS);                                          
01300900   END;                                                                             
01301000   WHILE SYMBOLIN(FACBEGSYS) DO BEGIN                                               
01301100     CASE SYMBOL OF BEGIN                                                           
01301200                                                                                    
01301300     IDENT:                                                                         
01301400       SEARCHID(KONSTVARFLDFNCSET OR PRCSET OR TYPESET,LCP);                        
01301500       INSYMBOL;                                                                    
01301600       IF (LCP = UTYPPTR) THEN BEGIN                                                
01301700         GTYPTR := NIL;                                                             
01301800       END ELSE BEGIN                                                               
01301900         IF (KLASS(LCP) = FUNC) OR                                                  
01302000         (KLASS(LCP)=PROC AND (KEY(LCP)=6 OR KEY(LCP)=15)) THEN BEGIN               
01302100              %ALLOW READ OR READLN FUNCTIONS                                       
01302200           IF (PFDECLKIND(LCP) = STANDARD) THEN BEGIN                               
01302300             READFUNCTION := TRUE;                                                  
01302400             CALLSTANDARD(FSYS,LCP);                                                
01302500             READFUNCTION := FALSE;                                                 
01302600           END ELSE BEGIN                                                           
01302700             CALLNONSTANDARD(FSYS,LCP);                                             
01302800             IF (GTYPTR = INTPTR) THEN BEGIN                                        
01302900               GBMIN := -MAXINT;                                                    
01303000               GBMAX := MAXINT;                                                     
01303100             END ELSE BEGIN                                                         
01303200               IF (GTYPTR = CHARPTR) THEN BEGIN                                     
01303300                 GBMIN := 0;                                                        
01303400                 GBMAX := IF ASCIITOG THEN 127 ELSE 255;                            
01303500               END ELSE BEGIN                                                       
01303600                 IF (GTYPTR=BOOLPTR) THEN BEGIN                                     
01303700                   GBMIN:=0;  GBMAX:=1;                                             
01303800                 END ELSE BEGIN                                                     
01303900                   IF (FORM(GTYPTR)<=SUBRANGE) THEN BEGIN                           
01304000                     GETBOUNDS(GTYPTR,GBMIN,GBMAX);                                 
01304100                   END;                                                             
01304200                 END;                                                               
01304300               END;                                                                 
01304400             END;                                                                   
01304500           END;                                                                     
01304600           GKIND:=EXPR;                                                             
01304700         END ELSE IF (KLASS(LCP) = KONST) THEN BEGIN                                
01304800           GTYPTR:=IDTYPE(LCP);                                                     
01304900           IF STRING(GTYPTR) THEN BEGIN                                             
01305000             GVLEVEL:=VLEV(LCP);                                                    
01305100             GDPLMT:=VADDR(LCP);                                                    
01305200             GIDPLMT:=VD1OFFSET(LCP);                                               
01305300             GACCESS:=INDRCT;                                                       
01305400             GCHARDESCR:=FALSE;                                                     
01305500             GCHARSIZE:=CHARBITSIZE;                                                
01305600             GKIND:=VARBL;                                                          
01305700           END ELSE BEGIN                                                           
01305800             GBMIN := GBMAX := GCVAL:=VALUES(LCP);                                  
01305900             GKIND:=CST;                                                            
01306000             GACCESS:=DRCT;                                                         
01306100           END;                                                                     
01306200         END ELSE BEGIN                                                             
01306300           IF(KLASS(LCP) = TYPES) THEN BEGIN                                        
01306400             IF STANDARDTOG THEN BEGIN                                              
01306500               ERROR(1844);                                                         
01306600             END;                                                                   
01306700             IF((IDTYPE(LCP) = REALPTR)                                             
01306800                OR COMPTYPES(IDTYPE(LCP),INTPTR)                                    
01306900                OR(FORM(IDTYPE(LCP)) NEQ SCALAR)) THEN BEGIN                        
01307000               ERROR(2840);                                                         
01307100               GTYPTR := NIL;                                                       
01307200             END ELSE BEGIN                                                         
01307300               IF(SYMBOL=LPARENT) THEN INSYMBOL ELSE ERROR(2842);                   
01307400               EXPRESSION(FSYS OR RPARENTSET);                                      
01307500               MAXBOUND:= IF(IDTYPE(LCP) = BOOLPTR) THEN 1                          
01307600                          ELSE IF (IDTYPE(LCP) = CHARPTR) THEN 255                  
01307700                          ELSE IF (GTYPTR = NIL) THEN 0                             
01307800                          ELSE VALUES(FCONST(GTYPTR));                              
01307900               IF(GTYPTR NEQ NIL) THEN BEGIN                                        
01308000                 GTYPTR:=IDTYPE(LCP);                                               
01308100               END;                                                                 
01308200               BOUNDSCHECK(0,MAXBOUND,FALSE);                                       
01308300               IF(SYMBOL=RPARENT) THEN INSYMBOL ELSE ERROR(2843);                   
01308400             END;                                                                   
01308500           END ELSE BEGIN                                                           
01308600             IF(KLASS(LCP)=PROC) THEN BEGIN                                         
01308700               ERROR(2830);                                                         
01308800             END ELSE BEGIN                                                         
01308900               SELECTOR(FSYS,LCP);                                                  
01309000               IF (GTYPTR = INTPTR) THEN BEGIN                                      
01309100                 GBMIN := -MAXINT;                                                  
01309200                 GBMAX := MAXINT;                                                   
01309300               END ELSE BEGIN                                                       
01309400                 IF (GTYPTR = CHARPTR) THEN BEGIN                                   
01309500                   GBMIN := 0;                                                      
01309600                   GBMAX := IF ASCIITOG THEN 127 ELSE 255;                          
01309700                 END ELSE BEGIN                                                     
01309800                   IF (GTYPTR=BOOLPTR) THEN BEGIN                                   
01309900                     GBMIN:=0;  GBMAX:=1;                                           
01310000                   END ELSE BEGIN                                                   
01310100                     IF (FORM(GTYPTR)<=SUBRANGE) THEN BEGIN                         
01310200                       GETBOUNDS(GTYPTR,GBMIN,GBMAX);                               
01310300                     END;                                                           
01310400                   END;                                                             
01310500                 END;                                                               
01310600               END;                                                                 
01310700             END;                                                                   
01310800           END;                                                                     
01310900         END;  % OF IF ON KLASS                                                     
01311000       END;                                                                         
01311100                                                                                    
01311200     INTCONST:                                                                      
01311300       GTYPTR:=INTPTR; GKIND:=CST; GBMIN:=GBMAX:=GCVAL:=VAL;                        
01311400       INSYMBOL;                                                                    
01311500                                                                                    
01311600     REALCONST:                                                                     
01311700       GTYPTR:=REALPTR; GKIND:=CST; GCVAL:=VAL;                                     
01311800       INSYMBOL;                                                                    
01311900                                                                                    
01312000     STRINGCONST:                                                                   
01312100       IF (LENGTH = 1) THEN BEGIN                                                   
01312200         GTYPTR:=CHARPTR; GKIND:=CST; GBMIN:=GBMAX:=GCVAL:=VAL;                     
01312300         INSYMBOL;                                                                  
01312400       END ELSE BEGIN                                                               
01312500         NEW(LSP,OTHERSTRUCTSIZE);                                                  
01312600         AELTYPE(LSP):=CHARPTR; FORM(LSP):=ARRAYS;                                  
01312700         SWORDS(LSP):=LENGTH*CHARSIZE;                                              
01312800         PACKED(LSP):=PACKEDSTRUC; BITS(LSP):=CHARBITSIZE;                          
01312900         GTYPTR:=LSP; GKIND:=VARBL; GACCESS:=INDRCT;                                
01313000         GCHARSIZE:=CHARBITSIZE; GCHARDESCR:=FALSE;                                 
01313100         ELSPERWORD(LSP):=6;                                                        
01313200           % FOR COMPATIBILITY AND CONSISTENCY A STRING IS A                        
01313300           % PACKED ARRAY[1..N] OF CHAR, SO PUT IN BOUNDS                           
01313400         NEW(LSP1,SUBRANGESTRUCTSIZE);                                              
01313500         FORM(LSP1):=SUBRANGE;                                                      
01313600         RANGETYPE(LSP1):=INTPTR;                                                   
01313700         SMIN(LSP1):=1;                                                             
01313800         SWORDS(LSP1):=INTSIZE;                                                     
01313900         SMAX(LSP1):=LENGTH;                                                        
01314000         INXTYPE(LSP):=LSP1;                                                        
01314100         INSYMBOL;                                                                  
01314200       END;                                                                         
01314300                                                                                    
01314400     LPARENT:                                                                       
01314500       INSYMBOL;                                                                    
01314600       EXPRESSION(FSYS OR RPARENTSET);                                              
01314700       IF (SYMBOL = RPARENT) THEN INSYMBOL ELSE ERROR(2831);                        
01314800                                                                                    
01314900     NOTSY:                                                                         
01315000       INSYMBOL;                                                                    
01315100       FACTOR(FSYS);                                                                
01315200       LOADV; GENOP(LNOT);                                                          
01315300       GENOP(ONE); GENOP(LAND);   %ISOLATE ONE BIT                                  
01315400       IF (GTYPTR NEQ NIL) THEN BEGIN                                               
01315500         IF (GTYPTR NEQ BOOLPTR) THEN BEGIN                                         
01315600           ERROR(2832); GTYPTR:=NIL;                                                
01315700         END;                                                                       
01315800       END;                                                                         
01315900                                                                                    
01316000     LBRACK:                                                                        
01316100       INSYMBOL;                                                                    
01316200       CSTPART:=VARPART:=GENARRAYDESCR:=FALSE;                                      
01316300       NEW(LSP,OTHERSTRUCTSIZE);                                                    
01316400       ELSET(LSP):=NIL; SWORDS(LSP):=SETSIZE; FORM(LSP):=POWER;                     
01316500       BITS(LSP):=SETBITSIZE;                                                       
01316600       SETTYPE(LSP):=IF(MAXSETSIZE>BITSPERWORD-1) THEN LSET ELSE SSET;              
01316700       NEW(LRP,SUBRANGESTRUCTSIZE);                                                 
01316800       FORM(LRP):=SUBRANGE;  SMIN(LRP):=MAXINT;  SMAX(LRP):=-MAXINT;                
01316900       RANGETYPE(LRP):=NIL;  ELSET(LSP):=LRP;                                       
01317000       IF (SYMBOL = RBRACK) THEN BEGIN                                              
01317100         IF (MAXSETSIZE>BITSPERWORD-1) THEN BEGIN                                   
01317200           WHILE (DECLAREDLC < LCMAX) DO BEGIN                                      
01317300             NEWTEMPVAR(LIP);                                                       
01317400             VLEV(LIP):=LEXLEVEL;  VADDR(LIP):=DECLAREDLC;                          
01317500             GENERATEONEWORD(LIP);                                                  
01317600             DECLAREDLC:=*+1;                                                       
01317700           END;                                                                     
01317800           LC:=LCMAX;  LCMAX:=*+1;  DECLAREDLC:=LCMAX;                              
01317900           GIDPLMT:=0;  GCHARDESCR:= FALSE;  GACCESS:=INDRCT;                       
01318000           GKIND:=VARBL;  SWORDS(LSP):=0;                                           
01318100           GVLEVEL:=LEXLEVEL;  GDPLMT:=LC;  LC:=*+1;                                
01318200           GENARRAYDESCR:=TRUE;                                                     
01318300           GTYPTR := LSP;                                                           
01318400           TEMPONSTACK:=TRUE;                                                       
01318500           COPYLATTRGATTR;                                                          
01318600           LMAX:=MAXSETSIZE;  LMIN:=0;  FSETSIZE:=LMAX+1;                           
01318700           SMIN(LRP):=LMIN;  SMAX(LRP):=LMAX;                                       
01318800 %         ZEROTEMP;                                                                
01318900         END ELSE BEGIN                                                             
01319000           GTYPTR:=LSP; GKIND:=CST; GCVAL:=0;                                       
01319100         END;                                                                       
01319200         INSYMBOL;                                                                  
01319300       END ELSE BEGIN                                                               
01319400         DO BEGIN                                                                   
01319500           IF TEMPONSTACK THEN BEGIN                                                
01319600             COPYLATTRGATTR;                                                        
01319700           END;                                                                     
01319800           EXPRESSION(FSYS OR COMMARBRACKSET OR COLONSET);                          
01319900           IF (GTYPTR NEQ NIL) THEN BEGIN                                           
01320000             IF (FORM(GTYPTR) > SUBRANGE) THEN BEGIN                                
01320100               ERROR(2833); GTYPTR:=NIL;                                            
01320200  $SET OMIT = NOT NAMECOMP                                                          
01320300             END ELSE IF IDENTCOMPTYPES(RANGETYPE(LRP),GTYPTR) THEN BEGIN           
01320400  $POP OMIT                                                                         
01320500  $SET OMIT =  NAMECOMP                                                             
01320600             END ELSE IF COMPTYPES(RANGETYPE(LRP),GTYPTR) THEN BEGIN                
01320700  $POP OMIT                                                                         
01320800               IF (GTYPTR = INTPTR) THEN BEGIN                                      
01320900                 LMIN:=0; LMAX := MAXSETSIZE;                                       
01321000               END ELSE BEGIN                                                       
01321100                 GETBOUNDS(GTYPTR,LMIN,LMAX);                                       
01321200               END;                                                                 
01321300               FSETSIZE:=LMAX+1;                                                    
01321400               IF (GKIND = CST) THEN BEGIN                                          
01321500                 CHECKLIMIT(GCVAL,0,LMAX);                                          
01321600                 IF (SYMBOL = COLON) THEN BEGIN                                     
01321700                   PROCESSSUBRANGEINSET;                                            
01321800                 END ELSE BEGIN                                                     
01321900                   IF (LMIN>=0) AND (LMAX<=47) THEN BEGIN                           
01322000                     CSTPART:=CSTPART & TRUE [GCVAL:1];                             
01322100                   END ELSE BEGIN                                                   
01322200                     SAVEGCVAL:=GCVAL;                                              
01322300                     IF (RANGETYPE(LRP)=NIL) THEN BEGIN                             
01322400                       IF (GTYPTR=CHARPTR) THEN BEGIN                               
01322500                         SETTYPE(LSP):=LSET;                                        
01322600                       END ELSE BEGIN                                               
01322700                         IF(FORM(GTYPTR)=SCALAR) THEN BEGIN                         
01322800                           IF (SCALKIND(GTYPTR)=DECLARED) THEN BEGIN                
01322900                             IF (VALUES(FCONST(GTYPTR))>BITSPERWORD-1)              
01323000                             THEN BEGIN                                             
01323100                               SETTYPE(LSP):=LSET;                                  
01323200                             END;                                                   
01323300                           END;                                                     
01323400                         END;                                                       
01323500                       END;                                                         
01323600                       WHILE (DECLAREDLC < LCMAX) DO BEGIN                          
01323700                         NEWTEMPVAR(LIP);                                           
01323800                         VLEV(LIP):=LEXLEVEL;  VADDR(LIP):=DECLAREDLC;              
01323900                         GENERATEONEWORD(LIP);                                      
01324000                         DECLAREDLC:=*+1;                                           
01324100                       END;                                                         
01324200                       LC:=LCMAX;  LCMAX:=*+1;  DECLAREDLC:=LCMAX;                  
01324300                       GIDPLMT:=0;  GCHARDESCR:= FALSE;  GACCESS:=INDRCT;           
01324400                       GKIND:=VARBL;  SWORDS(LSP):=0;                               
01324500                       GVLEVEL:=LEXLEVEL;  GDPLMT:=LC;  LC:=*+1;                    
01324600                       RANGETYPE(LRP):=GTYPTR;                                      
01324700                       GTYPTR := LSP;                                               
01324800                       GENARRAYDESCR:=TRUE;                                         
01324900                       TEMPONSTACK:=TRUE;                                           
01325000                       COPYLATTRGATTR;                                              
01325100                       ZEROTEMP;                                                    
01325200                     END ELSE BEGIN                                                 
01325300                       COPYGATTRLATTR;                                              
01325400                     END;                                                           
01325500                     LWORD:=SAVEGCVAL DIV BITSPERWORD;                              
01325600                     LBIT:=BITSPERWORD-1-(SAVEGCVAL MOD BITSPERWORD);               
01325700                     GENLIT(LWORD);                                                 
01325800                     GENV(VALC,GVLEVEL,GDPLMT);                                     
01325900                     GENOP1(BSET,LBIT);                                             
01326000                     GENLIT(LWORD);                                                 
01326100                     GENV(NAMC,GVLEVEL,GDPLMT);                                     
01326200                     GENOP(INDX);                                                   
01326300                     GENOP(STOD);                                                   
01326400                     GTYPTR := RANGETYPE(LRP);                                      
01326500                   END;                                                             
01326600                 END;                                                               
01326700               END ELSE BEGIN                                                       
01326800                 LOADV;                                                             
01326900                 SETSUBRBOUNDS(0,IF(GTYPTR=INTPTR) THEN MAXSETSIZE ELSE             
01327000                   GBMAX);                                                          
01327100                 IF (LMIN>=0) AND (LMAX<=47) THEN BEGIN                             
01327200                   IF (SYMBOLIN(COMMARBRACKSET)) THEN BEGIN                         
01327300                     IF VARPART THEN BEGIN                                          
01327400                       GENOP(DBST);                                                 
01327500                     END ELSE BEGIN                                                 
01327600                       GENOP(ZERO); GENOP(EXCH); GENOP(DBST);                       
01327700                       VARPART:=TRUE;                                               
01327800                     END;                                                           
01327900                   END ELSE BEGIN                                                   
01328000                     IF (SYMBOL=COLON) THEN BEGIN                                   
01328100                       GENOP(DUPL);                                                 
01328200                       INSYMBOL;                                                    
01328300                       EXPRESSION(FSYS OR COMMARBRACKSET);                          
01328400                       SETSUBRBOUNDS(0,IF(GTYPTR=INTPTR) THEN MAXSETSIZE            
01328500                          ELSE GBMAX);                                              
01328600  $SET OMIT = NOT NAMECOMP                                                          
01328700                       IF NOT IDENTCOMPTYPES(RANGETYPE(LRP),GTYPTR) THEN            
01328800  $POP OMIT                                                                         
01328900  $SET OMIT = NAMECOMP                                                              
01329000                       IF NOT COMPTYPES(RANGETYPE(LRP),GTYPTR) THEN                 
01329100  $POP OMIT                                                                         
01329200                         ERROR(2834);                                               
01329300                       LOADV;                                                       
01329400                       GENOP(DUPL);                                                 
01329500                       GENOP(RSDN);                                                 
01329600                       GENOP(GRTR);                                                 
01329700                       LAB1:=MAKELABEL;                                             
01329800                       LAB2:=MAKELABEL;                                             
01329900                       GENBR(BRFL,LAB1);                                            
01330000                       GENOP(DLET);  GENOP(DLET);                                   
01330100                       IF NOT VARPART THEN BEGIN                                    
01330200                         GENOP(ZERO);                                               
01330300                       END;                                                         
01330400                       GENBR(BRUN,LAB2);                                            
01330500                       GENLABEL(LAB1);                                              
01330600                       GENOP(DUPL);                                                 
01330700                       GENOP(RSDN);                                                 
01330800                       GENOP(EXCH);                                                 
01330900                       GENOP(SUBT);  GENOP(ONE);  GENOP(ADD);                       
01331000                       IF VARPART THEN GENOP(RSUP);                                 
01331100                       GENOP(ZERO);                                                 
01331200                       GENOP(LNOT);                                                 
01331300                       IF NOT VARPART THEN BEGIN                                    
01331400                         GENOP(ZERO);                                               
01331500                         VARPART := TRUE;                                           
01331600                       END;                                                         
01331700                       GENOP(EXCH);                                                 
01331800                       GENOP(DINS);                                                 
01331900                       GENLABEL(LAB2);                                              
01332000                     END;                                                           
01332100                   END;                                                             
01332200                 END ELSE BEGIN     %LONG SET                                       
01332300                   IF NOT GENARRAYDESCR THEN BEGIN                                  
01332400                     IF (GTYPTR=CHARPTR) THEN BEGIN                                 
01332500                       SETTYPE(LSP):=LSET;                                          
01332600                     END ELSE BEGIN                                                 
01332700                       IF(FORM(GTYPTR)=SCALAR) THEN BEGIN                           
01332800                         IF (SCALKIND(GTYPTR)=DECLARED) THEN BEGIN                  
01332900                           IF (VALUES(FCONST(GTYPTR))>BITSPERWORD-1)                
01333000                           THEN BEGIN                                               
01333100                             SETTYPE(LSP):=LSET;                                    
01333200                           END;                                                     
01333300                         END;                                                       
01333400                       END;                                                         
01333500                     END;                                                           
01333600                     GENARRAYDESCR:=TRUE;                                           
01333700                     GVLEVEL:=LEXLEVEL;  GDPLMT:=LCMAX;                             
01333800                     WHILE (DECLAREDLC < LCMAX) DO BEGIN                            
01333900                       NEWTEMPVAR(LIP);                                             
01334000                       VLEV(LIP):=LEXLEVEL;  VADDR(LIP):=DECLAREDLC;                
01334100                       GENERATEONEWORD(LIP);                                        
01334200                       DECLAREDLC:=*+1;                                             
01334300                     END;                                                           
01334400                     LC:=LCMAX+1;  LCMAX:=*+1;  DECLAREDLC:=LCMAX;                  
01334500                     RANGETYPE(LRP):=GTYPTR;                                        
01334600                     GCHARDESCR:=FALSE;                                             
01334700                     GTYPTR := LSP;  SWORDS(LSP):= 0;                               
01334800                     GACCESS:=INDRCT;  GIDPLMT:=0;                                  
01334900                     GKIND:=VARBL;                                                  
01335000                     COPYLATTRGATTR;                                                
01335100                     ZEROTEMP;                                                      
01335200                     TEMPONSTACK:=TRUE;                                             
01335300                   END;                                                             
01335400                   GENV(NAMC,1,INTRINSICADDR(PASCALLONGSETBITSADDR,                 
01335500                     PASCALINTRINSIC(PASCALLONGSETBITSINTR)));                      
01335600                   GENOP(EXCH);                                                     
01335700                   GENOP(IMKS);                                                     
01335800                   IF (SYMBOLIN(COMMARBRACKSET)) THEN BEGIN                         
01335900                     GENOP(DUPL);  COPYGATTRLATTR;  LOADIRW;                        
01336000                   END ELSE BEGIN                                                   
01336100                     COPYGATTRLATTR;                                                
01336200                     LOADIRW;                                                       
01336300                     IF (SYMBOL=COLON) THEN BEGIN                                   
01336400                       INSYMBOL;                                                    
01336500                       EXPRESSION(FSYS OR COMMARBRACKSET);                          
01336600  $SET OMIT = NOT NAMECOMP                                                          
01336700                       IF NOT IDENTCOMPTYPES(RANGETYPE(LRP),GTYPTR) THEN            
01336800  $POP OMIT                                                                         
01336900  $SET OMIT = NAMECOMP                                                              
01337000                       IF NOT COMPTYPES(RANGETYPE(LRP),GTYPTR) THEN                 
01337100  $POP OMIT                                                                         
01337200                         ERROR(2834);                                               
01337300                       LOADV;                                                       
01337400                       SETSUBRBOUNDS(0,IF(GTYPTR=INTPTR) THEN MAXSETSIZE            
01337500                          ELSE GBMAX);                                              
01337600                     END ELSE BEGIN                                                 
01337700                       GENOP(DUPL);                                                 
01337800                     END;                                                           
01337900                     GENOP(RSDN);                                                   
01338000                   END;                                                             
01338100                   GTYPTR := RANGETYPE(LRP);                                        
01338200                   GENLIT(LMIN);                                                    
01338300                   GENLIT(LMAX);                                                    
01338400                   GENOP(ENTR);                                                     
01338500                 END;                                                               
01338600               END;                                                                 
01338700               RANGETYPE(LRP):=GTYPTR;                                              
01338800               IF LONGSET(LSP) THEN BEGIN                                           
01338900                 COPYGATTRLATTR;                                                    
01339000               END ELSE BEGIN                                                       
01339100                 GTYPTR := LSP;                                                     
01339200               END;                                                                 
01339300             END ELSE BEGIN                                                         
01339400               ERROR(2834);                                                         
01339500             END; % OF IF                                                           
01339600           END; % OF IF (GTYPTR NEQ NIL)                                            
01339700           TEST:=(SYMBOL NEQ COMMA);                                                
01339800           IF NOT TEST THEN INSYMBOL;                                               
01339900         END UNTIL TEST;                                                            
01340000         IF (SYMBOL = RBRACK) THEN INSYMBOL ELSE ERROR(2835);                       
01340100       END;                                                                         
01340200       IF GENARRAYDESCR THEN BEGIN                                                  
01340300         SWORDS(LSP):=(FSETSIZE+BITSPERWORD-1) DIV BITSPERWORD;                     
01340400         GENERATEARRAYDESCRIPTOR(SWORDS(LSP),LIP);                                  
01340500         IF (REAL(CSTPART) ISNT 0) THEN BEGIN                                       
01340600           COPYGATTRLATTR;                                                          
01340700           GENOP(ZERO);                                                             
01340800           GENV(NAMC,GVLEVEL,GDPLMT);                                               
01340900           GENOP(INDX);                                                             
01341000           GENLIT(REAL(CSTPART));                                                   
01341100           GENOP(STOD);                                                             
01341200           GTYPTR := LSP;                                                           
01341300         END;                                                                       
01341400       END;                                                                         
01341500       IF (LMIN>=0) AND (LMAX<=47) THEN BEGIN                                       
01341600         IF VARPART THEN BEGIN                                                      
01341700           IF (REAL(CSTPART) ISNT 0) THEN BEGIN                                     
01341800             GENLIT(REAL(CSTPART)); GENOP(LOR);                                     
01341900           END;                                                                     
01342000         END ELSE BEGIN                                                             
01342100           GENLIT(REAL(CSTPART));                                                   
01342200         END;                                                                       
01342300         GKIND:=EXPR;                                                               
01342400       END;                                                                         
01342500                                                                                    
01342600     END; % OF CASE                                                                 
01342700     IF NOT SYMBOLIN(FSYS) THEN BEGIN                                               
01342800       ERROR(2836); SKIP(FSYS OR FACBEGSYS);                                        
01342900     END;                                                                           
01343000   END; % OF WHILE                                                                  
01343100 END; % OF FACTOR                                                                   
01343200                                                                                    
01343300                                                                                    
01343400   %         ********                                                               
01343500   % BODY OF * TERM *                                                               
01343600   %         ********                                                               
01343700   FACTOR(FSYS OR MULOPSET);                                                        
01343800   WHILE (SYMBOL = MULOP) DO BEGIN                                                  
01343900     IF LONGSET(GTYPTR) THEN BEGIN                                                  
01344000       SETTEMPONSTACK;                                                              
01344100       LOADIRW;                                                                     
01344200       GENOP(IMKS);                                                                 
01344300       GENV(NAMC,1,INTRINSICADDR(PASCALLONGSETOPERATORADDR,                         
01344400         PASCALINTRINSIC(PASCALLONGSETOPERATORINTR)));                              
01344500       GENOP(RSDN);                                                                 
01344600     END ELSE BEGIN                                                                 
01344700       LOADV;                                                                       
01344800     END;                                                                           
01344900     COPYLATTRGATTR; LOP:=OP;                                                       
01345000     INSYMBOL; FACTOR(FSYS OR MULOPSET);                                            
01345100     IF LONGSET(GTYPTR) THEN BEGIN                                                  
01345200       LOADIRW;                                                                     
01345300       GENLIT(SWORDS(GTYPTR));                                                      
01345400     END ELSE BEGIN                                                                 
01345500       LOADV;                                                                       
01345600     END;                                                                           
01345700     IF (LTYPTR NEQ NIL) AND (GTYPTR NEQ NIL) THEN BEGIN                            
01345800       CASE LOP OF BEGIN                                                            
01345900                                                                                    
01346000       MUL:                                                                         
01346100         IF (COMPTYPES(LTYPTR,INTPTR)) AND (COMPTYPES(GTYPTR,INTPTR))               
01346200         THEN BEGIN                                                                 
01346300           GENOP(MULT);                                                             
01346400           SETEXPRBOUNDS(LBMIN,LBMAX,GBMIN,GBMAX,LOP);                              
01346500         END ELSE BEGIN                                                             
01346600           IF (COMPTYPES(LTYPTR,INTPTR)) THEN LTYPTR:=REALPTR;                      
01346700           IF (COMPTYPES(GTYPTR,INTPTR)) THEN GTYPTR:=REALPTR;                      
01346800           IF (LTYPTR = REALPTR) AND (GTYPTR = REALPTR) THEN BEGIN                  
01346900             GENOP(MULT);                                                           
01347000           END ELSE IF (FORM(LTYPTR) = POWER) AND                                   
01347100             COMPTYPES(LTYPTR,GTYPTR) THEN BEGIN                                    
01347200             IF (SETTYPE(GTYPTR)=LSET) THEN BEGIN                                   
01347300  $SET OMIT = VMODE                                                                 
01347400               GENOP(ONE);                                                          
01347500  $POP OMIT                                                                         
01347600  $SET OMIT = NOT VMODE                                                             
01347700               IF (SWORDS(GTYPTR)>512) THEN BEGIN                                   
01347800                 GENOP(ONE);                                                        
01347900               END ELSE BEGIN                                                       
01348000                 GENOP1(LT8,4);                                                     
01348100               END;                                                                 
01348200  $POP  OMIT                                                                        
01348300               GENOP(ENTR);                                                         
01348400               COPYGATTRLATTR;                                                      
01348500             END ELSE BEGIN                                                         
01348600               GENOP(LAND);                                                         
01348700             END;                                                                   
01348800           END ELSE BEGIN                                                           
01348900             ERROR(2820); GTYPTR:=NIL;                                              
01349000           END;                                                                     
01349100         END;                                                                       
01349200                                                                                    
01349300       REALDIV:                                                                     
01349400         IF (COMPTYPES(LTYPTR,INTPTR)) THEN LTYPTR:=REALPTR;                        
01349500         IF (COMPTYPES(GTYPTR,INTPTR)) THEN GTYPTR:=REALPTR;                        
01349600         IF (LTYPTR = REALPTR) AND (GTYPTR = REALPTR) THEN BEGIN                    
01349700           GENOP(DIVD);                                                             
01349800         END ELSE BEGIN                                                             
01349900           ERROR(2821); GTYPTR:=NIL;                                                
01350000         END;                                                                       
01350100                                                                                    
01350200       JDIV:                                                                        
01350300         IF (COMPTYPES(LTYPTR,INTPTR)) AND (COMPTYPES(GTYPTR,INTPTR))               
01350400         THEN BEGIN                                                                 
01350500           SETEXPRBOUNDS(LBMIN,LBMAX,GBMIN,GBMAX,LOP);                              
01350600           GENOP(IDIV);                                                             
01350700         END ELSE BEGIN                                                             
01350800           ERROR(2822); GTYPTR:=NIL;                                                
01350900         END;                                                                       
01351000                                                                                    
01351100       IMOD:                                                                        
01351200         IF (COMPTYPES(LTYPTR,INTPTR)) AND (COMPTYPES(GTYPTR,INTPTR))               
01351300         THEN BEGIN                                                                 
01351400           SETEXPRBOUNDS(LBMIN,LBMAX,GBMIN,GBMAX,LOP);                              
01351500           GENOP(RDIV);                                                             
01351600         END ELSE BEGIN                                                             
01351700           ERROR(2823); GTYPTR:=NIL;                                                
01351800         END;                                                                       
01351900                                                                                    
01352000       ANDOP:                                                                       
01352100         IF (LTYPTR = BOOLPTR) AND (GTYPTR = BOOLPTR) THEN BEGIN                    
01352200           GENOP(LAND);                                                             
01352300         END ELSE BEGIN                                                             
01352400           ERROR(2824); GTYPTR:=NIL;                                                
01352500         END;                                                                       
01352600                                                                                    
01352700       END; % OF CASE                                                               
01352800     END ELSE BEGIN                                                                 
01352900       GTYPTR:=NIL;                                                                 
01353000     END;                                                                           
01353100   END; % OF WHILE                                                                  
01353200 END; % OF TERM                                                                     
01353300                                                                                    
01353400                                                                                    
01353500   %         ********************                                                   
01353600   % BODY OF * SIMPLEEXPRESSION *                                                   
01353700   %         ********************                                                   
01353800   SIGNTHERE:=SIGNED:=FALSE;                                                        
01353900   IF (SYMBOL = ADDOP) AND INTEST(OP,PLUSMINUSSET) THEN BEGIN                       
01354000     SIGNED:=(OP = MINUS); INSYMBOL;                                                
01354100     SIGNTHERE:=TRUE;                                                               
01354200   END;                                                                             
01354300   TERM(FSYS OR ADDOPSET);                                                          
01354400   IF SIGNTHERE THEN BEGIN                                                          
01354500     IF NOT((COMPTYPES(GTYPTR,INTPTR)) OR (GTYPTR=REALPTR)) THEN BEGIN              
01354600       ERROR(2814);                                                                 
01354700     END;                                                                           
01354800   END;                                                                             
01354900   IF SIGNED THEN BEGIN                                                             
01355000     IF (COMPTYPES(GTYPTR,INTPTR)) OR (GTYPTR = REALPTR) THEN BEGIN                 
01355100       IF (GKIND=CST) THEN BEGIN                                                    
01355200         GBMIN:=GBMAX:=GCVAL:=-GCVAL;                                               
01355300       END ELSE BEGIN                                                               
01355400         LOADV;                                                                     
01355500         GENOP(CHSN);                                                               
01355600         LCVAL:=GBMIN;  GBMIN:=-GBMAX;  GBMAX:=-LCVAL;                              
01355700       END;                                                                         
01355800     END ELSE BEGIN                                                                 
01355900       ERROR(2810); GTYPTR:=NIL;                                                    
01356000     END;                                                                           
01356100   END;                                                                             
01356200   WHILE (SYMBOL = ADDOP) DO BEGIN                                                  
01356300     IF LONGSET(GTYPTR) THEN BEGIN                                                  
01356400       SETTEMPONSTACK;                                                              
01356500       LOADIRW;                                                                     
01356600       GENOP(IMKS);                                                                 
01356700       GENV(NAMC,1,INTRINSICADDR(PASCALLONGSETOPERATORADDR,                         
01356800         PASCALINTRINSIC(PASCALLONGSETOPERATORINTR)));                              
01356900       GENOP(RSDN);                                                                 
01357000     END ELSE BEGIN                                                                 
01357100       LOADV;                                                                       
01357200     END;                                                                           
01357300     COPYLATTRGATTR; LOP:=OP;                                                       
01357400     INSYMBOL;                                                                      
01357500     TERM(FSYS OR ADDOPSET);                                                        
01357600     IF LONGSET(GTYPTR) THEN BEGIN                                                  
01357700       LOADIRW;                                                                     
01357800       GENLIT(SWORDS(GTYPTR));                                                      
01357900     END ELSE BEGIN                                                                 
01358000       LOADV;                                                                       
01358100     END;                                                                           
01358200     IF (LTYPTR NEQ NIL) AND (GTYPTR NEQ NIL) THEN BEGIN                            
01358300       CASE LOP OF BEGIN                                                            
01358400         %                                                                          
01358500       PLUS:                                                                        
01358600         IF (COMPTYPES(LTYPTR,INTPTR)) AND (COMPTYPES(GTYPTR,INTPTR))               
01358700         THEN BEGIN                                                                 
01358800           SETEXPRBOUNDS(LBMIN,LBMAX,GBMIN,GBMAX,LOP);                              
01358900           GENOP(ADD);                                                              
01359000         END ELSE BEGIN                                                             
01359100           IF (COMPTYPES(LTYPTR,INTPTR)) THEN LTYPTR:=REALPTR;                      
01359200           IF (COMPTYPES(GTYPTR,INTPTR)) THEN GTYPTR:=REALPTR;                      
01359300           IF (LTYPTR = REALPTR) AND (GTYPTR = REALPTR) THEN BEGIN                  
01359400             GENOP(ADD);                                                            
01359500           END ELSE IF (FORM(LTYPTR) = POWER) AND                                   
01359600             COMPTYPES(LTYPTR,GTYPTR) THEN BEGIN                                    
01359700             IF (SETTYPE(GTYPTR)=LSET) THEN BEGIN                                   
01359800  $SET OMIT = VMODE                                                                 
01359900               GENOP(ZERO);                                                         
01360000  $POP OMIT                                                                         
01360100  $SET OMIT = NOT VMODE                                                             
01360200               IF (SWORDS(GTYPTR)>512) THEN BEGIN                                   
01360300                 GENOP(ZERO);                                                       
01360400               END ELSE BEGIN                                                       
01360500                 GENOP1(LT8,3);                                                     
01360600               END;                                                                 
01360700  $POP OMIT                                                                         
01360800               GENOP(ENTR);                                                         
01360900               COPYGATTRLATTR;                                                      
01361000             END ELSE BEGIN                                                         
01361100               GENOP(LOR);                                                          
01361200             END;                                                                   
01361300           END ELSE BEGIN                                                           
01361400             ERROR(2811); GTYPTR:=NIL;                                              
01361500           END;                                                                     
01361600         END;                                                                       
01361700                                                                                    
01361800       MINUS:                                                                       
01361900         IF (COMPTYPES(LTYPTR,INTPTR)) AND (COMPTYPES(GTYPTR,INTPTR))               
01362000         THEN BEGIN                                                                 
01362100           SETEXPRBOUNDS(LBMIN,LBMAX,GBMIN,GBMAX,LOP);                              
01362200           GENOP(SUBT);                                                             
01362300         END ELSE BEGIN                                                             
01362400           IF (COMPTYPES(LTYPTR,INTPTR)) THEN LTYPTR:=REALPTR;                      
01362500           IF (COMPTYPES(GTYPTR,INTPTR)) THEN GTYPTR:=REALPTR;                      
01362600           IF (LTYPTR = REALPTR) AND (GTYPTR = REALPTR) THEN BEGIN                  
01362700             GENOP(SUBT);                                                           
01362800           END ELSE IF (FORM(LTYPTR) = POWER) AND                                   
01362900             COMPTYPES(LTYPTR,GTYPTR) THEN BEGIN                                    
01363000             IF (SETTYPE(GTYPTR)=LSET) THEN BEGIN                                   
01363100  $SET OMIT = VMODE                                                                 
01363200               GENOP1(LT8,2);                                                       
01363300  $POP OMIT                                                                         
01363400  $SET OMIT = NOT VMODE                                                             
01363500               IF (SWORDS(GTYPTR)>512) THEN BEGIN                                   
01363600                 GENOP1(LT8,2);                                                     
01363700               END ELSE BEGIN                                                       
01363800                 GENOP1(LT8,5);                                                     
01363900               END;                                                                 
01364000  $POP OMIT                                                                         
01364100               GENOP(ENTR);                                                         
01364200               COPYGATTRLATTR;                                                      
01364300             END ELSE BEGIN                                                         
01364400               GENOP(LNOT); GENOP(LAND);                                            
01364500             END;                                                                   
01364600           END ELSE BEGIN                                                           
01364700             ERROR(2812); GTYPTR:=NIL;                                              
01364800           END;                                                                     
01364900         END;                                                                       
01365000                                                                                    
01365100       OROP:                                                                        
01365200         IF (LTYPTR = BOOLPTR) AND (GTYPTR = BOOLPTR) THEN BEGIN                    
01365300           GENOP(LOR);                                                              
01365400         END ELSE BEGIN                                                             
01365500           ERROR(2813); GTYPTR:=NIL;                                                
01365600         END;                                                                       
01365700                                                                                    
01365800       END; % OF CASE                                                               
01365900     END ELSE BEGIN                                                                 
01366000       GTYPTR:=NIL;                                                                 
01366100     END;                                                                           
01366200   END; % OF WHILE                                                                  
01366300 END; % OF SIMPLEEXPRESSION                                                         
01366400                                                                                    
01366500                                                                                    
01366600 PROCEDURE GENREL(RELATIONALOPERATOR);                                              
01366700 %         ******                                                                   
01366800 VALUE RELATIONALOPERATOR;                                                          
01366900 TYPEOPERATOR RELATIONALOPERATOR;                                                   
01367000 BEGIN                                                                              
01367100   LABEL FORCESEGMENTATION;                                                         
01367200   %                                                                                
01367300   CASE RELATIONALOPERATOR OF BEGIN                                                 
01367400     EQOP: GENOP(EQUL);                                                             
01367500     NEOP: GENOP(NEQL);                                                             
01367600     GTOP: GENOP(GRTR);                                                             
01367700     LTOP: GENOP(LESS);                                                             
01367800     GEOP: GENOP(GREQ);                                                             
01367900     LEOP: GENOP(LSEQ);                                                             
01368000   END;                                                                             
01368100 END; % OF GEN RELATIONAL OPERATOR                                                  
01368200                                                                                    
01368300                                                                                    
01368400 PROCEDURE GENMULTIREL(FOP,FSIZE);                                                  
01368500 %         ***********                                                              
01368600 VALUE FOP,FSIZE;                                                                   
01368700 TYPEOPERATOR FOP;                                                                  
01368800 INTEGER FSIZE;                                                                     
01368900 BEGIN                                                                              
01369000   LABEL FORCESEGMENTATION;                                                         
01369100   DEFINE                                                                           
01369200     CHARBITS(X)=((BITS(X)=4) OR (BITS(X)=6) OR (BITS(X)=8))#;                      
01369300   %                                                                                
01369400 IF (FSIZE>0) THEN BEGIN                                                            
01369500   IF STRING(GTYPTR) OR CHARBITS(GTYPTR) THEN BEGIN                                 
01369600     GENLIT(FSIZE);                                                                 
01369700     CASE FOP OF BEGIN                                                              
01369800       EQOP: GENOP(CEQD);                                                           
01369900       NEOP: GENOP(CNED);                                                           
01370000       GTOP: GENOP(CGTD);                                                           
01370100       LTOP: GENOP(CLSD);                                                           
01370200       GEOP: GENOP(CGED);                                                           
01370300       LEOP: GENOP(CLED);                                                           
01370400     END;                                                                           
01370500     GENOP(RTFF);                                                                   
01370600   END ELSE BEGIN                                                                   
01370700     IF(BITS(GTYPTR)=1) THEN BEGIN                                                  
01370800       GENLIT((FSIZE-1) DIV BITSPERWORD+1);                                         
01370900     END ELSE BEGIN                                                                 
01371000       GENLIT(FSIZE);                                                               
01371100     END;                                                                           
01371200  $SET OMIT = VMODE                                                                 
01371300     GENOP(ZERO);                                                                   
01371400  $POP OMIT                                                                         
01371500  $SET OMIT = NOT VMODE                                                             
01371600     IF (BITS(GTYPTR)=1) THEN BEGIN                                                 
01371700       IF (FSIZE DIV BITSPERWORD > 512) THEN GENOP(ZERO)                            
01371800                                        ELSE GENOP(ONE);                            
01371900     END ELSE BEGIN                                                                 
01372000       IF (FSIZE>512) THEN GENOP(ZERO)                                              
01372100                      ELSE GENOP(ONE);                                              
01372200     END;                                                                           
01372300  $POP OMIT                                                                         
01372400     GENOP(ENTR);                                                                   
01372500     IF (FOP NEQ EQOP) THEN BEGIN                                                   
01372600       GENOP(ONE);                                                                  
01372700       GENREL(FOP);                                                                 
01372800     END;                                                                           
01372900   END;                                                                             
01373000 END;     %OF IF                                                                    
01373100 END;                                                                               
01373200                                                                                    
01373300 PROCEDURE INSETRANGECHECK(STYPTR,ACTMIN,ACTMAX);                                   
01373400 %         ***************                                                          
01373500 VALUE STYPTR,ACTMIN,ACTMAX;                                                        
01373600 REAL ACTMIN,ACTMAX;                                                                
01373700 TYPESTRUCTPTR STYPTR;                                                              
01373800 BEGIN                                                                              
01373900   INTEGER LMIN,LMAX,LABOK,LABERR;                                                  
01374000   BOOLEAN TESTSGENERATED;                                                          
01374100                                                                                    
01374200   GETBOUNDS(ELSET(STYPTR),LMIN,LMAX);                                              
01374300   IF((ACTMIN<LMIN) OR (ACTMAX>LMAX))  THEN BEGIN                                   
01374400     IF (LMAX<ACTMIN) OR (ACTMAX<LMIN) THEN BEGIN                                   
01374500       GENOP(DLET);                                                                 
01374600       GENOP(DLET);                                                                 
01374700       GENOP(ZERO);                                                                 
01374800     END ELSE BEGIN                                                                 
01374900       TESTSGENERATED := FALSE;                                                     
01375000       IF BOUNDSCHECKTOG THEN BEGIN                                                 
01375100         IF (ACTMIN<LMIN) THEN BEGIN     %MIN TEST                                  
01375200           GENOP(DUPL);                                                             
01375300           GENLIT(LMIN);                                                            
01375400           GENOP(LESS);                                                             
01375500           LABERR:=MAKELABEL;                                                       
01375600           GENBR(BRTR,LABERR);                                                      
01375700           TESTSGENERATED := TRUE;                                                  
01375800         END;                                                                       
01375900         IF (ACTMAX > LMAX) THEN BEGIN                                              
01376000           GENOP(DUPL);                                                             
01376100           GENLIT(LMAX);                                                            
01376200           GENOP(GRTR);                                                             
01376300           IF NOT TESTSGENERATED THEN BEGIN                                         
01376400             LABERR := MAKELABEL;                                                   
01376500             TESTSGENERATED := TRUE;                                                
01376600           END;                                                                     
01376700           GENBR(BRTR,LABERR);                                                      
01376800         END;                                                                       
01376900       END;                                                                         
01377000       GENOP(ONE);                                                                  
01377100       GENOP(DISO);                                                                 
01377200       IF TESTSGENERATED THEN BEGIN                                                 
01377300         LABOK:=MAKELABEL;                                                          
01377400         GENBR(BRUN,LABOK);                                                         
01377500         GENLABEL(LABERR);                                                          
01377600         GENOP(DLET);                                                               
01377700         GENOP(DLET);                                                               
01377800         GENOP(ZERO);                                                               
01377900         GENLABEL(LABOK);                                                           
01378000       END;                                                                         
01378100     END;                                                                           
01378200   END ELSE BEGIN                                                                   
01378300     GENOP(ONE);                                                                    
01378400     GENOP(DISO);                                                                   
01378500   END;                                                                             
01378600 END;   %OF INSETRANGECHECKS                                                        
01378700                                                                                    
01378800                                                                                    
01378900   %         **************                                                         
01379000   % BODY OF * EXPRESSION *                                                         
01379100   %         **************                                                         
01379200   DEFINE LTGTLEGESET=BOOLEAN(4"0F00")#;                                            
01379300   %                                                                                
01379400   TEMPONSTACK:=FALSE;                                                              
01379500   SIMPLEEXPRESSION(FSYS OR RELOPSET);                                              
01379600   IF (SYMBOL = RELOP) THEN BEGIN                                                   
01379700     IF (GTYPTR NEQ NIL) THEN BEGIN                                                 
01379800       IF (FORM(GTYPTR) <= POWER) THEN BEGIN                                        
01379900         IF LONGSET(GTYPTR) THEN BEGIN                                              
01380000           LOADIRW;                                                                 
01380100           GENOP(IMKS);                                                             
01380200           GENV(NAMC,1,INTRINSICADDR(PASCALLONGSETCOMPAREADDR,                      
01380300             PASCALINTRINSIC(PASCALLONGSETCOMPAREINTR)));                           
01380400           GENOP(RSDN);                                                             
01380500         END ELSE BEGIN                                                             
01380600           LOADV;                                                                   
01380700         END;                                                                       
01380800       END ELSE BEGIN                                                               
01380900         IF STRING(GTYPTR) THEN BEGIN                                               
01381000           LOADINXDDESCRIPTOR;                                                      
01381100         END ELSE BEGIN                                                             
01381200           LOADIRW;                                                                 
01381300           GENOP(IMKS);                                                             
01381400         END;                                                                       
01381500       END;                                                                         
01381600     END;                                                                           
01381700     COPYLATTRGATTR; LOP:=OP;                                                       
01381800     IF (GTYPTR NEQ NIL) THEN BEGIN                                                 
01381900       IF (FORM(GTYPTR) > POWER) THEN BEGIN                                         
01382000         IF NOT STRING(GTYPTR) THEN BEGIN                                           
01382100           GENV(NAMC,1,(IF((LOP=EQOP) OR (LOP=NEOP)) THEN                           
01382200               INTRINSICADDR(PASCALARRAYEQUALADDR,                                  
01382300                   PASCALINTRINSIC(PASCALARRAYEQUALINTR))                           
01382400               ELSE                                                                 
01382500               INTRINSICADDR(PASCALARRAYCOMPAREADDR,                                
01382600                   PASCALINTRINSIC(PASCALARRAYCOMPAREADDR))));                      
01382700           GENOP(RSDN);                                                             
01382800         END;                                                                       
01382900       END;                                                                         
01383000     END;                                                                           
01383100     INSYMBOL;                                                                      
01383200     SIMPLEEXPRESSION(FSYS);                                                        
01383300     IF(GTYPTR NEQ NIL) THEN BEGIN                                                  
01383400       IF (FORM(GTYPTR) <= POWER) THEN BEGIN                                        
01383500         IF LONGSET(GTYPTR) THEN BEGIN                                              
01383600           IF (LOP = INOPR) THEN BEGIN                                              
01383700             LOADADDRESS;                                                           
01383800             GENOP(IMKS);                                                           
01383900             GENV(NAMC,1,INTRINSICADDR(PASCALLONGSETINADDR,                         
01384000               PASCALINTRINSIC(PASCALLONGSETININTR)));                              
01384100             GENOP(RSDN);                                                           
01384200             LOADIRW;                                                               
01384300           END ELSE BEGIN                                                           
01384400             LOADIRW;                                                               
01384500             GENLIT(SWORDS(GTYPTR));                                                
01384600           END;                                                                     
01384700         END ELSE BEGIN                                                             
01384800           LOADV;                                                                   
01384900         END;                                                                       
01385000       END ELSE BEGIN                                                               
01385100         IF STRING(GTYPTR) THEN BEGIN                                               
01385200           LOADINXDDESCRIPTOR;                                                      
01385300         END ELSE BEGIN                                                             
01385400           LOADIRW;                                                                 
01385500         END;                                                                       
01385600       END;                                                                         
01385700     END;                                                                           
01385800     IF (LTYPTR NEQ NIL) AND (GTYPTR NEQ NIL) THEN BEGIN                            
01385900       IF (LOP = INOPR) THEN BEGIN                                                  
01386000         IF (FORM(GTYPTR) = POWER) THEN BEGIN                                       
01386100           IF COMPTYPES(LTYPTR,ELSET(GTYPTR)) THEN BEGIN                            
01386200             IF SHORTSET(GTYPTR) THEN BEGIN                                         
01386300               GENOP(EXCH);                                                         
01386400               INSETRANGECHECK(GTYPTR,LBMIN,LBMAX);                                 
01386500             END ELSE BEGIN                                                         
01386600               GETBOUNDS(ELSET(GTYPTR),LBMIN,LBMAX);                                
01386700               GENLIT(LBMIN);                                                       
01386800               GENLIT(LBMAX);                                                       
01386900               GENOP(ENTR);                                                         
01387000             END;                                                                   
01387100           END ELSE BEGIN                                                           
01387200             ERROR(2800); GTYPTR:=NIL;                                              
01387300           END;                                                                     
01387400         END ELSE BEGIN                                                             
01387500           ERROR(2801); GTYPTR:=NIL;                                                
01387600         END;                                                                       
01387700       END ELSE BEGIN                                                               
01387800         IF ( NOT COMPTYPES(LTYPTR,GTYPTR)) THEN BEGIN                              
01387900           IF (COMPTYPES(LTYPTR,INTPTR)) THEN LTYPTR:=REALPTR                       
01388000           ELSE IF (COMPTYPES(GTYPTR,INTPTR)) THEN GTYPTR:=REALPTR;                 
01388100         END;                                                                       
01388200         IF COMPTYPES(LTYPTR,GTYPTR) THEN BEGIN                                     
01388300           LSIZE:=SWORDS(LTYPTR);                                                   
01388400           LBITS:=BITS(LTYPTR);                                                     
01388500           CASE FORM(LTYPTR) OF BEGIN                                               
01388600                                                                                    
01388700           SCALAR:                                                                  
01388800           SUBRANGE:                                                                
01388900             GENREL(LOP);                                                           
01389000                                                                                    
01389100           POINTERS:                                                                
01389200             IF INTEST(LOP,LTGTLEGESET) THEN BEGIN                                  
01389300               ERROR(2802);                                                         
01389400             END ELSE BEGIN                                                         
01389500               GENREL(LOP);                                                         
01389600             END;                                                                   
01389700                                                                                    
01389800           POWER:                                                                   
01389900             IF (SETTYPE(GTYPTR)=SSET) THEN BEGIN                                   
01390000               CASE LOP OF BEGIN                                                    
01390100                 %                                                                  
01390200               EQOP:                                                                
01390300                 GENOP(SAME);                                                       
01390400               NEOP:                                                                
01390500                 GENOP(SAME); GENOP(LNOT);                                          
01390600               LEOP: GEOP:                                                          
01390700                 IF (LOP = GEOP) THEN GENOP(EXCH);                                  
01390800                 GENOP(LNOT); GENOP(LAND); GENOP(ZERO); GENOP(SAME);                
01390900               ELSE:                                                                
01391000                 ERROR(2803);                                                       
01391100                 %                                                                  
01391200               END;                                                                 
01391300             END ELSE BEGIN                                                         
01391400               CASE LOP OF BEGIN                                                    
01391500                %                                                                   
01391600               EQOP: NEOP:                                                          
01391700  $SET OMIT = VMODE                                                                 
01391800                 GENOP(ZERO);                                                       
01391900  $POP OMIT                                                                         
01392000  $SET OMIT = NOT VMODE                                                             
01392100                 IF (SWORDS(GTYPTR) > 512) THEN BEGIN                               
01392200                   GENOP(ZERO);                                                     
01392300                 END ELSE BEGIN                                                     
01392400                   GENOP1(LT8,3);                                                   
01392500                 END;                                                               
01392600               LEOP:                                                                
01392700  $SET OMIT = VMODE                                                                 
01392800                 GENOP1(LT8,2);                                                     
01392900  $POP OMIT                                                                         
01393000  $SET OMIT = NOT VMODE                                                             
01393100                 IF (SWORDS(GTYPTR) > 512) THEN GENOP1(LT8,2)                       
01393200                                           ELSE GENOP1(LT8,5);                      
01393300  $POP OMIT                                                                         
01393400               GEOP:                                                                
01393500  $SET OMIT = VMODE                                                                 
01393600                 GENOP(ONE);                                                        
01393700  $POP OMIT                                                                         
01393800  $SET OMIT = NOT VMODE                                                             
01393900                 IF (SWORDS(GTYPTR) > 512) THEN GENOP(ONE)                          
01394000                                           ELSE GENOP1(LT8,4);                      
01394100  $POP OMIT                                                                         
01394200               ELSE:                                                                
01394300                 ERROR(2803);                                                       
01394400                %                                                                   
01394500               END;                                                                 
01394600               GENOP(ENTR);                                                         
01394700               IF (LOP=NEOP) THEN BEGIN                                             
01394800                 GENOP(LNOT);  GENOP(ONE);  GENOP(LAND);                            
01394900               END;                                                                 
01395000             END;                                                                   
01395100                                                                                    
01395200           ARRAYS:                                                                  
01395300             IF NOT STRING(LTYPTR) AND INTEST(LOP,LTGTLEGESET) THEN                 
01395400             BEGIN                                                                  
01395500               ERROR(2804);                                                         
01395600  $SET OMIT = NAMECOMP                                                              
01395700             END ELSE BEGIN                                                         
01395800               IF (STRING(GTYPTR)) THEN  BEGIN                                      
01395900                 IF NOT STRING(LTYPTR) THEN BEGIN                                   
01396000                   ERROR(2809);                                                     
01396100                 END;                                                               
01396200               END;                                                                 
01396300  $POP OMIT                                                                         
01396400             END;                                                                   
01396500             GENMULTIREL(LOP,LSIZE);                                                
01396600                                                                                    
01396700           RECORDS:                                                                 
01396800             IF INTEST(LOP,LTGTLEGESET) THEN ERROR(2805);                           
01396900             GENMULTIREL(LOP,LSIZE);                                                
01397000                                                                                    
01397100           FILES:                                                                   
01397200             ERROR(2806);                                                           
01397300                                                                                    
01397400           END; % OF CASE                                                           
01397500         END ELSE BEGIN                                                             
01397600           ERROR(2807);                                                             
01397700         END;                                                                       
01397800       END;                                                                         
01397900       GTYPTR:=BOOLPTR; GKIND:=EXPR;                                                
01398000     END; % OF BOTH TYPTRS NIL                                                      
01398100   END; % OF IF (SYMBOL = RELOP)                                                    
01398200 END; % OF EXPRESSION                                                               
01398300                                                                                    
01398400                                                                                    
01398500 %END OF EXPRESSION *****************************************************           
01398600                                                                                    
01398700                                                                                    
01398800 PROCEDURE ASSIGNMENT(IDENTIFIERPTR,FROMIOLISTELEMENT);                             
01398900 %         **********                                                               
01399000 VALUE IDENTIFIERPTR,FROMIOLISTELEMENT;                                             
01399100 TYPEIDENTPTR IDENTIFIERPTR;                                                        
01399200 BOOLEAN FROMIOLISTELEMENT;                                                         
01399300 BEGIN                                                                              
01399400   INTEGER LAB;                                                                     
01399500   DECLARELATTR;                                                                    
01399600   %                                                                                
01399700   IF (NOT FROMIOLISTELEMENT) THEN SELECTOR((FSYS OR BECOMESSET),                   
01399800       IDENTIFIERPTR);                                                              
01399900   IF (SYMBOL = BECOMES) THEN BEGIN                                                 
01400000     IF (GTYPTR NEQ NIL) THEN BEGIN                                                 
01400100       IF (FORM(GTYPTR) > POWER) OR LONGSET(GTYPTR) THEN BEGIN                      
01400200         IF (SWORDS(GTYPTR)>0) THEN BEGIN                                           
01400300           LOADSTRINGDESCRIPTOR;                                                    
01400400         END;                                                                       
01400500       END ELSE IF (GKIND = VARBL) THEN BEGIN                                       
01400600         LOADADDRIFINXD;                                                            
01400700       END;                                                                         
01400800     END;                                                                           
01400900     IF (VFORCONTRL(IDENTIFIERPTR)=REAL(TRUE)) THEN BEGIN                           
01401000       ERROR(2643);                                                                 
01401100     END;                                                                           
01401200     IF (KLASS(IDENTIFIERPTR) = FUNC) THEN BEGIN                                    
01401300       IF (PFDECLKIND(IDENTIFIERPTR) = DECLARED) THEN BEGIN                         
01401400         IF ((PFLEV(IDENTIFIERPTR) > LEXLEVEL) OR                                   
01401500           (FNCOMPLETE(IDENTIFIERPTR) = FNFINISHED)) THEN BEGIN                     
01401600           ERROR(2645);                                                             
01401700         END;                                                                       
01401800       END;                                                                         
01401900     END;                                                                           
01402000     COPYLATTRGATTR;                                                                
01402100     INSYMBOL;                                                                      
01402200     EXPRESSION(FSYS);                                                              
01402300     IF (GTYPTR NEQ NIL) THEN BEGIN                                                 
01402400       IF (FORM(GTYPTR) < POWER) OR SHORTSET(GTYPTR) THEN LOADV                     
01402500       ELSE BEGIN                                                                   
01402600         IF (SWORDS(GTYPTR)>0) THEN BEGIN                                           
01402700           LOADSTRINGDESCRIPTOR;                                                    
01402800         END;                                                                       
01402900       END;                                                                         
01403000     END;                                                                           
01403100     IF (LTYPTR NEQ NIL) AND (GTYPTR NEQ NIL) THEN BEGIN                            
01403200  $SET OMIT = NAMECOMP                                                              
01403300       IF COMPTYPES(REALPTR,LTYPTR) AND (GTYPTR=INTPTR) THEN BEGIN                  
01403400         GTYPTR:=REALPTR;                                                           
01403500       END;                                                                         
01403600       IF COMPTYPES (LTYPTR,GTYPTR) OR                                              
01403700  $POP OMIT                                                                         
01403800  $SET OMIT = NOT NAMECOMP                                                          
01403900       IF ASSCOMPTYPES(LTYPTR,GTYPTR) OR                                            
01404000  $POP OMIT                                                                         
01404100         (STRING(LTYPTR) AND STRING(GTYPTR) AND (SWORDS(LTYPTR)>=                   
01404200         SWORDS(GTYPTR))) THEN BEGIN                                                
01404300         CASE FORM(LTYPTR) OF BEGIN                                                 
01404400           %                                                                        
01404500         SCALAR:                                                                    
01404600         SUBRANGE:                                                                  
01404700           IF (COMPTYPES(LTYPTR,INTPTR)) THEN GENOP(NTGR);                          
01404800           IF (FORM(LTYPTR)=SUBRANGE) THEN BEGIN                                    
01404900             RANGECHECK(SMIN(LTYPTR),SMAX(LTYPTR),GBMIN,GBMAX);                     
01405000           END;                                                                     
01405100           IF (LPACKEDARRAY) THEN BEGIN                                             
01405200             CASE LCHARSIZE OF BEGIN                                                
01405300             1: 48: STORE(LATTRPARAMETERS,STOD);                                    
01405400             4: 6: 8: STORE(LATTRPARAMETERS,TUND);                                  
01405500             END;                                                                   
01405600           END ELSE BEGIN                                                           
01405700             STORE(LATTRPARAMETERS,STOD);                                           
01405800           END;                                                                     
01405900         POINTERS:                                                                  
01406000             STORE(LATTRPARAMETERS,STOD);                                           
01406100         POWER:                                                                     
01406200           IF SHORTSET(LTYPTR) THEN BEGIN                                           
01406300             IF BOUNDSCHECKTOG THEN BEGIN                                           
01406400               GETBOUNDS(ELSET(LTYPTR),LBMIN,LBMAX);                                
01406500               IF(LBMIN NEQ 0) OR (LBMAX NEQ 47) THEN BEGIN                         
01406600                 STORE(LATTRPARAMETERS,STON);                                       
01406700                 GENOP(ZERO);                                                       
01406800                 GENOP2(INSR,LBMAX,LBMAX-LBMIN+1);                                  
01406900                 GENOP(ZERO);                                                       
01407000                 GENOP(SAME);                                                       
01407100                 LAB:=MAKELABEL;                                                    
01407200                 GENBR(BRTR,LAB);                                                   
01407300                 RUNTIMEERROR(BOUNDSERROR);                                         
01407400                 GENLABEL(LAB);                                                     
01407500               END ELSE BEGIN                                                       
01407600                 STORE(LATTRPARAMETERS,STOD);                                       
01407700               END;                                                                 
01407800             END ELSE BEGIN                                                         
01407900               STORE(LATTRPARAMETERS,STOD);                                         
01408000             END;                                                                   
01408100           END ELSE BEGIN                                                           
01408200             GENLIT(MIN(SWORDS(LTYPTR),SWORDS(GTYPTR)));                            
01408300             GENOP(TWSD);   %NO BOUNDS CHECKING ON LONG SETS                        
01408400           END;                                                                     
01408500         ARRAYS:                                                                    
01408600         RECORDS:                                                                   
01408700           IF (SWORDS(LTYPTR)>0) THEN BEGIN                                         
01408800             IF (PACKED(GTYPTR)=UNPACKEDSTRUC) THEN  BEGIN                          
01408900               GENLIT(SWORDS(LTYPTR)); GENOP(TWSD);                                 
01409000             END ELSE BEGIN                                                         
01409100               CASE BITS(GTYPTR) OF BEGIN                                           
01409200               1: GENLIT((SWORDS(LTYPTR)-1) DIV BITSPERWORD+1);                     
01409300                  GENOP(TWSD);                                                      
01409400               4:6:                                                                 
01409500                  GENLIT(SWORDS(LTYPTR));                                           
01409600                  GENOP(TUND);                                                      
01409700               8:                                                                   
01409800  $SET OMIT = NAMECOMP                                                              
01409900                  IF (STRING(GTYPTR)) THEN  BEGIN                                   
01410000                    IF NOT STRING(LTYPTR) THEN BEGIN                                
01410100                      ERROR(2644);                                                  
01410200                    END;                                                            
01410300                  END;                                                              
01410400  $POP OMIT                                                                         
01410500                 GENLIT(SWORDS(GTYPTR));                                            
01410600                 IF(SWORDS(GTYPTR) < SWORDS(LTYPTR)) THEN BEGIN                     
01410700                   GENOP(TUNU);                                                     
01410800                   GENOP(DLET);                                                     
01410900                   GENLIT("      ");                                                
01411000                   GENLIT(SWORDS(LTYPTR)-SWORDS(GTYPTR));                           
01411100                   IF STANDARDTOG THEN ERROR(1643);                                 
01411200                 END;                                                               
01411300                 GENOP(TUND);                                                       
01411400               48:                                                                  
01411500                  GENLIT(SWORDS(LTYPTR)); GENOP(TWSD);                              
01411600               END;                                                                 
01411700             END;                                                                   
01411800           END;                                                                     
01411900         FILES:                                                                     
01412000           ERROR(2640);                                                             
01412100           %                                                                        
01412200         END; % OF CASE                                                             
01412300       END ELSE BEGIN                                                               
01412400         ERROR(2641);                                                               
01412500       END;                                                                         
01412600     END; % OF BOTH TYPES NIL TESTED                                                
01412700   END ELSE BEGIN                                                                   
01412800     ERROR(2642);                                                                   
01412900   END;                                                                             
01413000 END; % OF ASSIGNMENT                                                               
01413100                                                                                    
01413200                                                                                    
01413300                                                                                    
01413400 PROCEDURE IOLISTELEMENT(IDENTIFIERPTR);                                            
01413500 %         *************                                                            
01413600 VALUE IDENTIFIERPTR;                                                               
01413700 TYPEIDENTPTR IDENTIFIERPTR;                                                        
01413800 BEGIN                                                                              
01413900   INTEGER LMIN,LMAX;                                                               
01414000   LABEL EXIT,AWAY;                                                                 
01414100   TYPESTRUCTPTR LTYPTR;                                                            
01414200   DEFINE                                                                           
01414300     ADJUSTSUBRANGEVALUE = BEGIN                                                    
01414400       IF(FORM(GTYPTR)=SUBRANGE) THEN BEGIN                                         
01414500         IF(SMIN(GTYPTR)>0) THEN BEGIN                                              
01414600           GENLIT(SMIN(GTYPTR));  GENOP(SUBT);                                      
01414700         END ELSE BEGIN                                                             
01414800           IF(SMIN(GTYPTR)<0) THEN BEGIN                                            
01414900             GENLIT(ABS(SMIN(GTYPTR)));  GENOP(ADD);                                
01415000           END;                                                                     
01415100         END;                                                                       
01415200       END;                                                                         
01415300       GPACKEDSUBRFIELD:=GPACKEDARRAY:=FALSE;                                       
01415400     END#,                                                                          
01415500     SIMPLETYPE(LTYPTR)=(LTYPTR=INTPTR OR LTYPTR=REALPTR                            
01415600                 OR LTYPTR=BOOLPTR OR LTYPTR=CHARPTR)#,                             
01415700     STRUCPTR = FORM(IDTYPE(IDENTIFIERPTR))#,                                       
01415800     GENTYPE(LPTR) =                                                                
01415900       IF STRING(GTYPTR) THEN BEGIN                                                 
01416000         GENLIT(9 & SWORDS(GTYPTR) [46:19]);                                        
01416100       END ELSE BEGIN                                                               
01416200         GENOP1(LT8,IF (LPTR = INTPTR) THEN 5                                       
01416300                    ELSE IF (LPTR = REALPTR) THEN 3                                 
01416400                         ELSE IF (LPTR = BOOLPTR) THEN 7                            
01416500                              ELSE IF (LPTR = CHARPTR)                              
01416600                                  THEN 5 ELSE 3);                                   
01416700       END;#;                                                                       
01416800                                                                                    
01416900   IF (KLASS(IDENTIFIERPTR) = TYPES) OR                                             
01417000      (KLASS(IDENTIFIERPTR) = FORMATS) THEN BEGIN                                   
01417100     ERROR(2922); SKIP(SEMICOLONRPARENTSET OR ENDSET);                              
01417200     GO AWAY;                                                                       
01417300   END;                                                                             
01417400   IF (KLASS(IDENTIFIERPTR) = KONST) AND (IDENTIFIERPTR NEQ UCSTPTR) THEN           
01417500       IF NOT((IDTYPE(IDENTIFIERPTR) = INTPTR) OR                                   
01417600            (IDTYPE(IDENTIFIERPTR) = REALPTR) OR                                    
01417700            (IDTYPE(IDENTIFIERPTR) = CHARPTR) OR                                    
01417800            STRING(IDTYPE(IDENTIFIERPTR)) OR                                        
01417900            (IDTYPE(IDENTIFIERPTR) = BOOLPTR)) THEN BEGIN                           
01418000         ERROR(2921); SKIP(SEMICOLONRPARENTSET OR ENDSET);                          
01418100         GO AWAY;                                                                   
01418200       END;                                                                         
01418300   IF(NOT(KLASS(IDENTIFIERPTR)=FUNC AND PFDECLKIND(IDENTIFIERPTR)=                  
01418400      STANDARD)) THEN                                                               
01418500   IF(STRUCPTR = POWER) OR                                                          
01418600     (STRUCPTR = SCALAR AND FCONST(IDTYPE(IDENTIFIERPTR)) NEQ NIL                   
01418700     AND (IDTYPE(IDENTIFIERPTR) NEQ BOOLPTR)                                        
01418800     AND IDENTIFIERPTR NEQ UCSTPTR) THEN BEGIN                                      
01418900     ERROR(2923); SKIP(SEMICOLONRPARENTSET OR ENDSET);                              
01419000     GO AWAY;                                                                       
01419100   END;                                                                             
01419200                                                                                    
01419300     LEXLEVEL := *+1;                                                               
01419400     IF (READWRITESTMT AND (STRUCPTR=ARRAYS OR STRUCPTR=RECORDS                     
01419500       OR STRUCPTR=POINTERS OR KLASS(IDENTIFIERPTR)=FIELD))                         
01419600     THEN BEGIN                                                                     
01419700       SELECTOR(FSYS OR BECOMESSET,IDENTIFIERPTR);                                  
01419800       IF (SYMBOL = BECOMES) THEN BEGIN                                             
01419900         ASSIGNMENT(IDENTIFIERPTR,TRUE);                                            
01420000         GO TO EXIT;                                                                
01420100       END;                                                                         
01420200       IF NOT(SIMPLETYPE(GTYPTR) OR                                                 
01420300              (FORM(GTYPTR)=SUBRANGE AND SIMPLETYPE(RANGETYPE(GTYPTR))))            
01420400       THEN ERROR (2924);                                                           
01420500       LTYPTR:=IF(FORM(GTYPTR)=SUBRANGE) THEN RANGETYPE(GTYPTR)                     
01420600               ELSE GTYPTR;                                                         
01420700       IF(GCHARSIZE=1 OR GCHARSIZE=BITSPERWORD) THEN BEGIN                          
01420800         LOADINXDDESCRIPTOR;                                                        
01420900         GENOP(DUPL);                                                               
01421000         IF((GCHARSIZE=1) AND (GACCESS=INXD)) THEN BEGIN                            
01421100           GENOP(RSDN);                                                             
01421200           GENOP(DUPL);                                                             
01421300         END;                                                                       
01421400         GENV(NAMC,LEXLEVEL,2);                                                     
01421500         GENOP(EXCH);                                                               
01421600         GENOP(IMKS);                                                               
01421700         GENTYPE(LTYPTR);                                                           
01421800         GENOP(EXCH);                                                               
01421900         GENOP(LOAD);                                                               
01422000       END ELSE BEGIN                                                               
01422100         LOADINXDDESCRIPTOR;                                                        
01422200         GENOP(MKST);                                                               
01422300         GENV(NAMC,LEXLEVEL,2);                                                     
01422400         GENTYPE(LTYPTR);                                                           
01422500         GENOP(ZERO);   %LOADV?                                                     
01422600       END;                                                                         
01422700       GENOP(ENTR);                                                                 
01422800       IF(FORM(GTYPTR)=SUBRANGE) THEN BEGIN                                         
01422900         IF BOUNDSCHECKTOG THEN BEGIN                                               
01423000           GETBOUNDS(GTYPTR,LMIN,LMAX);                                             
01423100           BOUNDSCHECK(LMIN,LMAX,TRUE);                                             
01423200         END;                                                                       
01423300       END;                                                                         
01423400       IF(GACCESS=INXD) THEN BEGIN                                                  
01423500         CASE GCHARSIZE OF BEGIN                                                    
01423600         1:48: STORE(GATTRPARAMETERS,STOD);                                         
01423700         4:6:8: STORE(GATTRPARAMETERS,TUND);                                        
01423800         END;                                                                       
01423900       END ELSE BEGIN                                                               
01424000         IF GPACKEDSUBRFIELD THEN BEGIN                                             
01424100           GENOP(EXCH);                                                             
01424200           GENOP(DUPL);                                                             
01424300           GENOP(LOAD);                                                             
01424400           GENOP(RSUP);                                                             
01424500           ADJUSTSUBRANGEVALUE;                                                     
01424600           GENOP2(INSR,GBITADDR,GBITRANGE);                                         
01424700           GENOP(STOD);                                                             
01424800         END ELSE BEGIN                                                             
01424900           IF(GCHARSIZE=BITSPERWORD) THEN BEGIN                                     
01425000             IF GPACKEDARRAY THEN BEGIN                                             
01425100               ADJUSTSUBRANGEVALUE;                                                 
01425200             END;                                                                   
01425300             GENOP(STOD);                                                           
01425400           END ELSE BEGIN                                                           
01425500             IF(GCHARSIZE=1) THEN BEGIN                                             
01425600               GENOP(EXCH);                                                         
01425700               GENOP(DUPL);                                                         
01425800               GENOP(LOAD);                                                         
01425900               GENOP(RSUP);                                                         
01426000               GENOP2(INSR,GBITADDR,BOOLBITSIZE);                                   
01426100               GENOP(STOD);                                                         
01426200             END ELSE BEGIN                                                         
01426300               IF GPACKEDARRAY THEN BEGIN                                           
01426400                 ADJUSTSUBRANGEVALUE;                                               
01426500               END;                                                                 
01426600               CASE GCHARSIZE OF BEGIN                                              
01426700               4: GENOP2(ISOL,3,48);                                                
01426800               6: GENOP2(ISOL,5,48);                                                
01426900               8: GENOP2(ISOL,7,48);                                                
01427000               END;                                                                 
01427100               GENOP(ONE);                                                          
01427200               GENOP(TUND);                                                         
01427300             END;                                                                   
01427400           END;                                                                     
01427500         END;                                                                       
01427600       END;                                                                         
01427700       LISTELEMENT := TRUE;                                                         
01427800     END ELSE BEGIN                                                                 
01427900       IF READWRITESTMT THEN                                                        
01428000         IF KLASS(IDENTIFIERPTR) = KONST OR KLASS(IDENTIFIERPTR)=FUNC               
01428100         THEN BEGIN                                                                 
01428200           ERROR(2920); SKIP(SEMICOLONENDSET);                                      
01428300         END ELSE                                                                   
01428400           SELECTOR(FSYS OR BECOMESSET,IDENTIFIERPTR)                               
01428500       ELSE                                                                         
01428600       BEGIN                                                                        
01428700         EXPRESSION(FSYS OR BECOMESSET);                                            
01428800         IF (GTYPTR = INTPTR) AND (GKIND = EXPR) THEN GENOP(NTGR);                  
01428900       END;                                                                         
01429000       IF ((GKIND=VARBL) AND (SYMBOL = BECOMES)) THEN BEGIN                         
01429100         ASSIGNMENT(IDENTIFIERPTR,TRUE);                                            
01429200         GO TO EXIT;                                                                
01429300       END;                                                                         
01429400       IF NOT(SIMPLETYPE(GTYPTR) OR                                                 
01429500              STRING(GTYPTR) OR                                                     
01429600              (FORM(GTYPTR)=SUBRANGE AND SIMPLETYPE(RANGETYPE(GTYPTR))))            
01429700       THEN ERROR (2924);                                                           
01429800       LTYPTR:=IF(FORM(GTYPTR)=SUBRANGE) THEN RANGETYPE(GTYPTR)                     
01429900               ELSE GTYPTR;                                                         
01430000       IF((GTYPTR NEQ NIL) AND (GKIND NEQ EXPR)) THEN BEGIN                         
01430100         IF (GKIND=CST OR GACCESS=DRCT ) THEN BEGIN                                 
01430200           GENOP(MKST);GENV(NAMC,LEXLEVEL,2);                                       
01430300           GENTYPE(LTYPTR);                                                         
01430400           IF READWRITESTMT THEN GENOP(ZERO) ELSE LOADV;                            
01430500         END ELSE BEGIN                                                             
01430600           IF(GPACKEDSUBRFIELD OR GPACKEDARRAY) THEN BEGIN                          
01430700             LOADV;                                                                 
01430800             GENV(NAMC,LEXLEVEL,2);GENOP(EXCH); GENOP(IMKS);                        
01430900           END ELSE BEGIN                                                           
01431000             LOADINXDDESCRIPTOR;                                                    
01431100             GENV(NAMC,LEXLEVEL,2);GENOP(EXCH); GENOP(IMKS);                        
01431200             IF NOT STRING(GTYPTR) THEN GENOP(LOAD);                                
01431300           END;                                                                     
01431400           GENTYPE(LTYPTR);                                                         
01431500           GENOP(EXCH);                                                             
01431600         END;                                                                       
01431700       END ELSE BEGIN                                                               
01431800         GENV(NAMC,LEXLEVEL,2);GENOP(EXCH); GENOP(IMKS);                            
01431900         GENTYPE(LTYPTR);                                                           
01432000         GENOP(EXCH);                                                               
01432100       END;                                                                         
01432200       GENOP(ENTR);                                                                 
01432300       IF (READWRITESTMT) THEN BEGIN                                                
01432400         IF(FORM(GTYPTR)=SUBRANGE) THEN BEGIN                                       
01432500           IF BOUNDSCHECKTOG THEN BEGIN                                             
01432600             GETBOUNDS(GTYPTR,LMIN,LMAX);                                           
01432700             BOUNDSCHECK(LMIN,LMAX,TRUE);                                           
01432800           END;                                                                     
01432900         END;                                                                       
01433000         GENV(NAMC,GVLEVEL,GDPLMT);                                                 
01433100         GENOP(STOD);                                                               
01433200         IF (VFORCONTRL(IDENTIFIERPTR)=REAL(TRUE)) THEN BEGIN                       
01433300           ERROR(2926);                                                             
01433400         END;                                                                       
01433500       END;                                                                         
01433600       LISTELEMENT := TRUE;                                                         
01433700     END;                                                                           
01433800     MAXFIELDSIZE := MAX(MAXFIELDSIZE,                                              
01433900       IF (GTYPTR = BOOLPTR) THEN 5                                                 
01434000       ELSE IF STRING(GTYPTR) THEN                                                  
01434100            SWORDS(GTYPTR) ELSE 18);                                                
01434200 EXIT:                                                                              
01434300     LEXLEVEL := *-1;                                                               
01434400 AWAY:                                                                              
01434500 END;  %OF IOLISTELEMENT                                                            
01434600                                                                                    
01434700                                                                                    
01434800 PROCEDURE COMPOUNDSTATEMENT;                                                       
01434900 %         =================                                                        
01435000 BEGIN                                                                              
01435100   DO BEGIN                                                                         
01435200     DO BEGIN                                                                       
01435300       STATEMENT(FSYS OR SEMICOLONENDSET);                                          
01435400     END UNTIL NOT SYMBOLIN(STATBEGSYS);                                            
01435500     TEST:=(SYMBOL NEQ SEMICOLON);                                                  
01435600     IF NOT TEST THEN INSYMBOL;                                                     
01435700   END UNTIL TEST;                                                                  
01435800   IF (SYMBOL=ENDSY) THEN INSYMBOL ELSE ERROR(2600);                                
01435900 END; % OF COMPOUND STATEMENT                                                       
01436000                                                                                    
01436100 PROCEDURE IFSTATEMENT;                                                             
01436200 %         ===========                                                              
01436300 BEGIN                                                                              
01436400   INTEGER LABELA,LABELB;                                                           
01436500   EXPRESSION(FSYS OR THENSET);                                                     
01436600   LOADV;                                                                           
01436700   LABELA:=MAKELABEL;                                                               
01436800   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01436900     IF (GTYPTR NEQ BOOLPTR) THEN BEGIN                                             
01437000       ERROR(2611); GTYPTR:=NIL;                                                    
01437100     END;                                                                           
01437200   END;                                                                             
01437300   GENBR(BRFL,LABELA);                                                              
01437400   IF (SYMBOL=THENSY) THEN INSYMBOL ELSE ERROR(2610);                               
01437500   STATEMENT(FSYS OR ELSESET);                                                      
01437600  $SET OMIT = OTHERWISE                                                             
01437700   IF (SYMBOL=ELSESY) THEN BEGIN                                                    
01437800  $POP OMIT                                                                         
01437900  $SET OMIT = NOT OTHERWISE                                                         
01438000   IF(SYMBOL = ELSESY AND OP=ELSEOP) THEN BEGIN                                     
01438100  $POP OMIT                                                                         
01438200     LABELB:=MAKELABEL;                                                             
01438300     GENBR(BRUN,LABELB);                                                            
01438400     GENLABEL(LABELA);                                                              
01438500     INSYMBOL;                                                                      
01438600     STATEMENT(FSYS);                                                               
01438700     GENLABEL(LABELB);                                                              
01438800   END ELSE BEGIN                                                                   
01438900     GENLABEL(LABELA);                                                              
01439000   END;                                                                             
01439100 END; % OF IF STATEMENT                                                             
01439200                                                                                    
01439300 PROCEDURE REPEATSTATEMENT;                                                         
01439400 %         ===============                                                          
01439500 BEGIN                                                                              
01439600   INTEGER LABELA;                                                                  
01439700   LABELA:=MAKELABEL;                                                               
01439800   GENLABEL(LABELA);                                                                
01439900   DO BEGIN                                                                         
01440000     DO BEGIN                                                                       
01440100       STATEMENT(FSYS OR SEMICOLONUNTILSET);                                        
01440200     END UNTIL NOT SYMBOLIN(STATBEGSYS);                                            
01440300     TEST:=(SYMBOL NEQ SEMICOLON);                                                  
01440400     IF NOT TEST THEN INSYMBOL;                                                     
01440500   END UNTIL TEST;                                                                  
01440600   IF (SYMBOL=UNTILSY) THEN BEGIN                                                   
01440700     INSYMBOL;                                                                      
01440800     EXPRESSION(FSYS);                                                              
01440900     LOADV;                                                                         
01441000     IF (GTYPTR NEQ NIL) THEN BEGIN                                                 
01441100       IF (GTYPTR NEQ BOOLPTR) THEN BEGIN                                           
01441200         ERROR(2621); GTYPTR:=NIL;                                                  
01441300       END;                                                                         
01441400     END;                                                                           
01441500     GENBR(BRFL,LABELA);                                                            
01441600   END ELSE BEGIN                                                                   
01441700     ERROR(2620);                                                                   
01441800   END;                                                                             
01441900 END; % OF REPEAT STATEMENT                                                         
01442000                                                                                    
01442100 PROCEDURE WHILESTATEMENT;                                                          
01442200 %         ==============                                                           
01442300 BEGIN                                                                              
01442400   INTEGER LABELA,LABELB;                                                           
01442500   LABELA:=MAKELABEL;                                                               
01442600   GENLABEL(LABELA);                                                                
01442700   EXPRESSION(FSYS OR DOSET);                                                       
01442800   LOADV;                                                                           
01442900   LABELB:=MAKELABEL;                                                               
01443000   IF (GTYPTR NEQ NIL) THEN BEGIN                                                   
01443100     IF (GTYPTR NEQ BOOLPTR) THEN BEGIN                                             
01443200       ERROR(2631); GTYPTR:=NIL;                                                    
01443300     END;                                                                           
01443400   END;                                                                             
01443500   GENBR(BRFL,LABELB);                                                              
01443600   IF (SYMBOL=DOSY) THEN INSYMBOL ELSE ERROR(2630);                                 
01443700   STATEMENT(FSYS);                                                                 
01443800   GENBR(BRUN,LABELA);                                                              
01443900   GENLABEL(LABELB);                                                                
01444000 END; % OF WHILE STATEMENT                                                          
01444100                                                                                    
01444200 PROCEDURE FORSTATEMENT;                                                            
01444300 %         ************                                                             
01444400 BEGIN                                                                              
01444500   DECLARELATTR;                                                                    
01444600   TYPESYMBOL DIRECTIONSYMBOL;                                                      
01444700   INTEGER TESTLABEL,EXITLABEL,FIRSTCONSTANT,LABERR,LABOK;                          
01444800   BOOLEAN POSSIBLESTBR,STBRLOOP;                                                   
01444900   TYPEIDENTPTR LCP;                                                                
01445000   REAL E1MIN,E1MAX;                                                                
01445100   %                                                                                
01445200   DEFINE FORBOUNDSCHECK = BEGIN                                                    
01445300     IF (FORM(LTYPTR)=SUBRANGE) THEN BEGIN                                          
01445400       IF BOUNDSCHECKTOG THEN BEGIN                                                 
01445500         LABERR:=0;                                                                 
01445600         IF NOT POSSIBLESTBR THEN BEGIN      %NOT A CONSTANT                        
01445700           IF ((E1MIN<LBMIN) AND (DIRECTIONSYMBOL=TOSY)) OR                         
01445800              ((E1MAX>LBMAX) AND (DIRECTIONSYMBOL=DOWNTOSY)) THEN BEGIN             
01445900             GENOP(DUPL);                                                           
01446000             IF (DIRECTIONSYMBOL=TOSY) THEN BEGIN                                   
01446100               GENLIT(LBMIN);                                                       
01446200               GENOP(LESS);                                                         
01446300             END ELSE BEGIN                                                         
01446400               GENLIT(LBMAX);                                                       
01446500               GENOP(GRTR);                                                         
01446600             END;                                                                   
01446700             LABERR:=MAKELABEL;                                                     
01446800             LABOK:=MAKELABEL;                                                      
01446900             GENBR(BRFL,LABOK);                                                     
01447000             GENLABEL(LABERR);                                                      
01447100             RUNTIMEERROR(5);                                                       
01447200             GENLABEL(LABOK);                                                       
01447300           END;                                                                     
01447400         END;                                                                       
01447500         IF (GKIND NEQ CST) THEN BEGIN                                              
01447600           IF ((GBMAX>LBMAX) AND (DIRECTIONSYMBOL=TOSY)) OR                         
01447700              ((GBMIN<LBMIN) AND (DIRECTIONSYMBOL=DOWNTOSY)) THEN BEGIN             
01447800             GENV(VALC,LEXLEVEL,LC);   %LC OF TEMP                                  
01447900             IF (DIRECTIONSYMBOL=TOSY) THEN BEGIN                                   
01448000               GENLIT(LBMAX);                                                       
01448100               GENOP(GRTR);                                                         
01448200             END ELSE BEGIN                                                         
01448300               GENLIT(LBMIN);                                                       
01448400               GENOP(LESS);                                                         
01448500             END;                                                                   
01448600             IF (LABERR=0) THEN BEGIN                                               
01448700               LABOK:=MAKELABEL;                                                    
01448800               GENBR(BRFL,LABOK);                                                   
01448900               RUNTIMEERROR(5);                                                     
01449000               GENLABEL(LABOK);                                                     
01449100             END ELSE BEGIN                                                         
01449200               GENBR(BRTR,LABERR);                                                  
01449300             END;                                                                   
01449400           END;                                                                     
01449500         END;                                                                       
01449600       END;                                                                         
01449700     END;                                                                           
01449800   END;#;                                                                           
01449900                                                                                    
01450000   POSSIBLESTBR:=STBRLOOP:=FALSE;          % ENSURE THIS                            
01450100   FIRSTCONSTANT:=0;                       %ENSURE THIS TOO                         
01450200   TESTLABEL:=0; % LETS ENSURE THAT OUR LABELS ARE CHECKABLE FOR USE                
01450300   IF (SYMBOL = IDENT) THEN BEGIN                                                   
01450400     SEARCHID((FALSE & SETB(VARS)),LCP);                                            
01450500     LTYPTR:=IDTYPE(LCP); LKIND:=VARBL;                                             
01450600     IF (VKIND(LCP) = ACTUAL) THEN BEGIN                                            
01450700       LACCESS:=DRCT;                                                               
01450800       LVLEVEL:=VLEV(LCP); LDPLMT:=VADDR(LCP);                                      
01450900       IF (FORM(LTYPTR)=SUBRANGE) THEN BEGIN                                        
01451000         LBMIN := SMIN(LTYPTR);                                                     
01451100         LBMAX := SMAX(LTYPTR);                                                     
01451200       END;                                                                         
01451300       IF (LVLEVEL NEQ LEXLEVEL) THEN                                               
01451400         IF STANDARDTOG THEN ERROR(1659);                                           
01451500       IF (VFORCONTRL(LCP)=REAL(FALSE)) THEN BEGIN                                  
01451600         VFORCONTRL(LCP):=REAL(TRUE);                                               
01451700       END ELSE BEGIN                                                               
01451800         ERROR(2658);                                                               
01451900       END;                                                                         
01452000     END ELSE BEGIN                                                                 
01452100       ERROR(2650); LTYPTR:=NIL;                                                    
01452200     END;                                                                           
01452300     IF (LTYPTR NEQ NIL) THEN BEGIN                                                 
01452400       IF (FORM(LTYPTR) > SUBRANGE) OR                                              
01452500       COMPTYPES(REALPTR,LTYPTR) THEN BEGIN                                         
01452600         ERROR(2651); LTYPTR:=NIL;                                                  
01452700       END;                                                                         
01452800     END;                                                                           
01452900     INSYMBOL;                                                                      
01453000   END ELSE BEGIN                                                                   
01453100     ERROR(2652);                                                                   
01453200     SKIP(FSYS OR BECOMESTODOWNTODOSET);                                            
01453300   END;                                                                             
01453400   IF (SYMBOL = BECOMES) THEN BEGIN                                                 
01453500     INSYMBOL;                                                                      
01453600     EXPRESSION(FSYS OR TODOWNTODOSET);                                             
01453700     E1MIN:=GBMIN;  E1MAX:=GBMAX;                                                   
01453800     IF (GTYPTR NEQ NIL) THEN BEGIN                                                 
01453900       IF (FORM(GTYPTR) > SUBRANGE) THEN BEGIN                                      
01454000         ERROR(2653);                                                               
01454100       END ELSE IF COMPTYPES(LTYPTR,GTYPTR) THEN BEGIN                              
01454200         IF (GKIND = CST) THEN BEGIN                                                
01454300           IF (GCVAL >= 0) AND (GCVAL < 65536) THEN BEGIN                           
01454400             POSSIBLESTBR:=TRUE; FIRSTCONSTANT:=GCVAL;                              
01454500           END;                                                                     
01454600         END;                                                                       
01454700         IF NOT POSSIBLESTBR THEN BEGIN                                             
01454800           LOADV;                                                                   
01454900           IF COMPTYPES(LTYPTR,INTPTR) THEN GENOP(NTGR);                            
01455000         END;                                                                       
01455100       END ELSE BEGIN                                                               
01455200         ERROR(2654);                                                               
01455300       END;                                                                         
01455400     END;                                                                           
01455500   END ELSE BEGIN                                                                   
01455600     ERROR(2655);                                                                   
01455700     SKIP(FSYS OR TODOWNTODOSET);                                                   
01455800   END;                                                                             
01455900   IF (SYMBOL = TOSY) OR (SYMBOL = DOWNTOSY) THEN BEGIN                             
01456000     DIRECTIONSYMBOL:=SYMBOL; INSYMBOL;                                             
01456100     EXPRESSION(FSYS & SETB(DOSY));                                                 
01456200     IF (GTYPTR NEQ NIL) THEN BEGIN                                                 
01456300       IF (FORM(GTYPTR) > SUBRANGE) THEN BEGIN                                      
01456400         ERROR(2653);                                                               
01456500       END ELSE IF COMPTYPES(LTYPTR,GTYPTR) THEN BEGIN                              
01456600         IF (GKIND = CST) THEN BEGIN                                                
01456700           STBRLOOP:= POSSIBLESTBR AND (DIRECTIONSYMBOL = TOSY)                     
01456800                      AND (GCVAL >= FIRSTCONSTANT)                                  
01456900                      AND (GCVAL < 65536);                                          
01457000           IF (FORM(LTYPTR)=SUBRANGE) AND NOT STBRLOOP THEN BEGIN                   
01457100             IF (DIRECTIONSYMBOL=TOSY) THEN BEGIN                                   
01457200               IF (GCVAL>LBMAX) THEN ERROR(2590);                                   
01457300             END ELSE BEGIN                                                         
01457400               IF (GCVAL<LBMIN) THEN ERROR(2590);                                   
01457500             END;                                                                   
01457600           END;                                                                     
01457700         END;                                                                       
01457800         % PERFORM LOOP INITIALIZATIONS                                             
01457900         IF STBRLOOP THEN BEGIN                                                     
01458000           GENLIT(4"001000000000" & FIRSTCONSTANT [15:16]                           
01458100                  & GCVAL [35:16]);      % THE STEP-INDEX WORD                      
01458200           GENOP1(LT8,4); GENOP(STAG);   % MAKE IT TAG 4                            
01458300           STORE(LATTRPARAMETERS,STOD);  % INTO THE CONTROL VAR                     
01458400           IF (FORM(LTYPTR)=SUBRANGE) THEN BEGIN                                    
01458500             IF (FIRSTCONSTANT<LBMIN) OR (GCVAL>LBMAX) THEN ERROR(2590);            
01458600           END;                                                                     
01458700         END ELSE BEGIN                                                             
01458800           LOADV;                   %GET EXPR 2                                     
01458900           IF COMPTYPES(LTYPTR,INTPTR) THEN GENOP(NTGR);                            
01459000           GENV(NAMC,LEXLEVEL,LC);                                                  
01459100           GENOP(STOD);                  % INTO A TEMPORARY                         
01459200           IF POSSIBLESTBR THEN BEGIN                                               
01459300             GENLIT(FIRSTCONSTANT);      % LOAD EXPR 1 BECAUSE WASNT                
01459400             IF COMPTYPES(LTYPTR,INTPTR) THEN GENOP(NTGR);                          
01459500             IF (FORM(LTYPTR)=SUBRANGE) THEN BEGIN                                  
01459600               IF (DIRECTIONSYMBOL=TOSY) THEN BEGIN                                 
01459700                 IF (FIRSTCONSTANT < LBMIN) THEN ERROR(2590);                       
01459800               END ELSE BEGIN                                                       
01459900                 IF (FIRSTCONSTANT>LBMAX) THEN ERROR(2590);                         
01460000               END;                                                                 
01460100             END;                                                                   
01460200           END;                                                                     
01460300           STORE(LATTRPARAMETERS,STON);                                             
01460400           FORBOUNDSCHECK;                                                          
01460500         END;                                                                       
01460600         % PUT THE LOOP-REPEAT LABEL HERE                                           
01460700         TESTLABEL:=MAKELABEL; GENLABEL(TESTLABEL);                                 
01460800         % IF NOTA STBR THEN PUT THE TEST CODE HERE                                 
01460900         IF NOT STBRLOOP THEN BEGIN                                                 
01461000           GENV(VALC,LEXLEVEL,LC);       % LOAD THE ENDLIMIT FROM TEMP              
01461100           IF (DIRECTIONSYMBOL = TOSY) THEN GENOP(LSEQ)                             
01461200             ELSE GENOP(GREQ);                                                      
01461300           LC:=LC+INTSIZE;               % BUMP TEMP COUNTER                        
01461400           IF (LC > LCMAX) THEN LCMAX:=LC;                                          
01461500         END;                                                                       
01461600       END ELSE BEGIN                                                               
01461700         ERROR(2654);                                                               
01461800       END;                                                                         
01461900     END;                                                                           
01462000   END ELSE BEGIN                                                                   
01462100     ERROR(2656);                                                                   
01462200     SKIP(FSYS OR DOSET);                                                           
01462300   END;                                                                             
01462400   EXITLABEL:=MAKELABEL;                                                            
01462500   % IF NOT OPTIMIZED, NEED THE JUMP-OUT TEST                                       
01462600   IF NOT STBRLOOP THEN BEGIN                                                       
01462700     GENBR(BRFL,EXITLABEL);                                                         
01462800   END;                                                                             
01462900   IF (SYMBOL = DOSY) THEN INSYMBOL ELSE ERROR(2657);                               
01463000   STATEMENT(FSYS);                                                                 
01463100   % PUT THE INCREMENTATION CODE                                                    
01463200   IF STBRLOOP THEN BEGIN                                                           
01463300     IF (LTYPTR NEQ NIL) THEN BEGIN                                                 
01463400       GENV(NAMC,LVLEVEL,LDPLMT);        % IRW TO THE CONTROL VAR                   
01463500     END;                                                                           
01463600     GENBR(STBR,EXITLABEL);              % INC, TEST & EXIT IN ONE                  
01463700     IF (TESTLABEL NEQ 0) THEN GENBR(BRTR,TESTLABEL);                               
01463800     RUNTIMEERROR(FORVARERROR);                     % SOMEONE OVERWROTE T           
01463900   END ELSE BEGIN                                                                   
01464000     COPYGATTRLATTR; LOADV;              % GET THE CONTROL VAR                      
01464100     GENOP(ONE);                                                                    
01464200     GENOP(IF (DIRECTIONSYMBOL = TOSY) THEN ADD ELSE SUBT);                         
01464300     STORE(LATTRPARAMETERS,STON);        % LEAVE RES ON TOS                         
01464400     IF (TESTLABEL NEQ 0) THEN GENBR(BRUN,TESTLABEL);                               
01464500   END;                                                                             
01464600   % PUT THE EXIT LABEL                                                             
01464700   GENLABEL(EXITLABEL);                                                             
01464800   % UNDEFINE THE CONTROL VARIABLE                                                  
01464900   GENOP(ZERO); GENOP1(LT8,6); GENOP(STAG);      % A TAG-SIX WORD                   
01465000   VFORCONTRL(LCP):=REAL(FALSE);                                                    
01465100   STORE(LATTRPARAMETERS,STOD);                                                     
01465200   IF(LC>DECLAREDLC AND NOT STBRLOOP) THEN LC := LC-1;                              
01465300 END; % OF FOR STATEMENT                                                            
01465400                                                                                    
01465500                                                                                    
01465600 PROCEDURE GOTOSTATEMENT;                                                           
01465700 %         *************                                                            
01465800 BEGIN                                                                              
01465900   TYPELBP LABELPTR;                                                                
01466000   BOOLEAN FOUND;                                                                   
01466100   INTEGER TTOP,SAVETTOP;                                                           
01466200   %                                                                                
01466300   IF LISTPROC THEN BEGIN                                                           
01466400     ERROR(2684);  SKIP(SEMICOLONRPARENTSET OR ENDSET);                             
01466500   END ELSE BEGIN                                                                   
01466600     IF (SYMBOL = INTCONST) THEN BEGIN                                              
01466700       IF (VAL <= 9999) THEN BEGIN                                                  
01466800         FOUND:=FALSE;                                                              
01466900         TTOP:=TOP;                                                                 
01467000         WHILE (OCCUR(TTOP) NEQ BLCK) DO TTOP:=TTOP-1;                              
01467100         SAVETTOP:=TTOP;                                                            
01467200         DO BEGIN                                                                   
01467300           LABELPTR:=FLABEL(TTOP);                                                  
01467400           WHILE (LABELPTR NEQ NIL) AND NOT FOUND DO BEGIN                          
01467500             IF (LABVAL(LABELPTR) = VAL) THEN BEGIN                                 
01467600               FOUND:=TRUE;                                                         
01467700               IF (TTOP = SAVETTOP) THEN BEGIN                                      
01467800                 GENBR(BRUN,LABNAME(LABELPTR));                                     
01467900               END ELSE BEGIN                                                       
01468000                 GENOP(MKST);                                                       
01468100                 GENV(NAMC,0,11);      %GOTOSOLVER                                  
01468200                 GENV(NAMC,LABLEV(LABELPTR),LABADDR(LABELPTR));                     
01468300                 GENOP(STFF);                                                       
01468400                 GENOP(ENTR);                                                       
01468500               END;                                                                 
01468600             END ELSE BEGIN                                                         
01468700               LABELPTR:=NEXTLAB(LABELPTR);                                         
01468800             END;                                                                   
01468900           END; % OF WHILE                                                          
01469000           TTOP:=TTOP-1;                                                            
01469100           WHILE (OCCUR(TTOP) NEQ BLCK) DO TTOP:=TTOP-1;                            
01469200         END UNTIL FOUND OR (TTOP = 0);                                             
01469300         IF NOT FOUND THEN ERROR(2681);                                             
01469400         INSYMBOL;                                                                  
01469500       END ELSE BEGIN                                                               
01469600         ERROR(2682);                                                               
01469700       END;                                                                         
01469800     END ELSE BEGIN                                                                 
01469900       ERROR(2683);                                                                 
01470000     END; % OF IF LABEL TOO BIG                                                     
01470100   END;                                                                             
01470200 END; % OF GOTO STATEMENT                                                           
01470300                                                                                    
01470400                                                                                    
01470500 PROCEDURE CASESTATEMENT;                                                           
01470600 %         *************                                                            
01470700 BEGIN                                                                              
01470800   LABEL FOUNDLABELPLACE;                                                           
01470900   DEFINE                                                                           
01471000         CSNEXT(P)       =HEAP[P].LOWFIELD#,                                        
01471100         CSSTART(P)      =HEAP[P].MIDFIELD#,                                        
01471200         CSLAB(P)        =HEAP[P+1]#,                                               
01471300         CASEINFOSIZE    =2#,                                                       
01471400         TYPECASEINFO    =INTEGER#;                                                 
01471500   TYPESTRUCTPTR LSP,LSP1,LSPEXPR;                                                  
01471600   TYPECASEINFO FSTPTR,LPT1,LPT2,LPT3;                                              
01471700   TYPEVALU LVALUE;                                                                 
01471800   INTEGER EXITLABEL,ELSELABEL,BUILDJUMPLAB,CASELABEL,LMIN,LMAX,RMAX,               
01471900     NOINTS,CURRVAL,CASETEMP;                                                       
01472000   BOOLEAN FINITETYPE,ONSTACK;                                                      
01472100   %                                                                                
01472200 PROCEDURE GENTREE(FINTS,FPTR1,FPTR2,LBOUND);                                       
01472300 %         *******                                                                  
01472400 VALUE FINTS,FPTR1,FPTR2,LBOUND;                                                    
01472500 INTEGER FINTS;                                                                     
01472600 BOOLEAN LBOUND;                                                                    
01472700 TYPESTRUCTPTR FPTR1,FPTR2;                                                         
01472800 BEGIN                                                                              
01472900 INTEGER                                                                            
01473000   LINTS,CURVAL,I,LAB;                                                              
01473100 TYPECASEINFO                                                                       
01473200   LPTR,LPTR2;                                                                      
01473300                                                                                    
01473400 LINTS := (FINTS+(IF(LBOUND) THEN 0 ELSE 1)) DIV 2;                                 
01473500 LPTR := LPTR2 := FPTR1;                                                            
01473600 CURVAL := CSLAB(LPTR);                                                             
01473700 I := IF LBOUND THEN 1 ELSE 2;                                                      
01473800 LPTR := CSNEXT(LPTR);                                                              
01473900 WHILE (I<LINTS) DO BEGIN                                                           
01474000   IF (CSLAB(LPTR) = (CURVAL+1)) THEN BEGIN                                         
01474100     IF (CSSTART(LPTR) NEQ CSSTART(LPTR2)) THEN BEGIN                               
01474200       I := I+1;                                                                    
01474300     END;                                                                           
01474400   END ELSE BEGIN                                                                   
01474500     I := I+2;                                                                      
01474600   END;                                                                             
01474700   CURVAL := CSLAB(LPTR);                                                           
01474800   LPTR2 := LPTR;                                                                   
01474900   LPTR := CSNEXT(LPTR);                                                            
01475000 END;   %OF WHILE                                                                   
01475100 IF (LPTR NEQ NIL) THEN BEGIN                                                       
01475200   IF ((LINTS>1) OR (LBOUND)) THEN BEGIN                                            
01475300     WHILE (CSLAB(LPTR)=(CURVAL+1)AND(CSSTART(LPTR)=CSSTART(LPTR2))) DO             
01475400     BEGIN                                                                          
01475500       CURVAL := CSLAB(LPTR);                                                       
01475600       LPTR2 := LPTR;                                                               
01475700       LPTR := CSNEXT(LPTR);                                                        
01475800     END;                                                                           
01475900   END;                                                                             
01476000 END;                                                                               
01476100 IF ONSTACK THEN BEGIN                                                              
01476200   ONSTACK := FALSE;                                                                
01476300 END ELSE BEGIN                                                                     
01476400   GENV(VALC,LEXLEVEL,CASETEMP);                                                    
01476500 END;                                                                               
01476600 GENLIT(CSLAB(LPTR2)-(IF((LINTS=1) AND (NOT LBOUND))                                
01476700       THEN 1 ELSE 0));                                                             
01476800 GENOP(GRTR);                                                                       
01476900 IF (LINTS>1) THEN BEGIN                                                            
01477000   IF(LPTR = NIL) THEN BEGIN                                                        
01477100     GENBR(BRTR,ELSELABEL);                                                         
01477200     GENTREE(I,FPTR1,LPTR2,LBOUND);                                                 
01477300   END ELSE BEGIN                                                                   
01477400     IF((FINTS-I=1) AND ((LPTR=NIL) OR (LPTR=FPTR2))) THEN BEGIN                    
01477500       IF (LPTR=NIL) THEN BEGIN                                                     
01477600         GENBR(BRTR,ELSELABEL);                                                     
01477700       END ELSE BEGIN                                                               
01477800         GENBR(BRTR,CSSTART(FPTR2));                                                
01477900       END;                                                                         
01478000       GENTREE(I,FPTR1,LPTR2,LBOUND);                                               
01478100     END ELSE BEGIN                                                                 
01478200       LAB := MAKELABEL;                                                            
01478300       GENBR(BRTR,LAB);                                                             
01478400       GENTREE(I,FPTR1,LPTR2,LBOUND);                                               
01478500       GENLABEL(LAB);                                                               
01478600       GENTREE(FINTS-I,LPTR,FPTR2,(CSLAB(LPTR)=CSLAB(LPTR2)+1));                    
01478700     END;                                                                           
01478800   END;                                                                             
01478900 END ELSE BEGIN                                                                     
01479000   IF (LBOUND) THEN BEGIN                                                           
01479100     GENBR(BRFL,CSSTART(LPTR2));                                                    
01479200     IF (LPTR = NIL) THEN BEGIN                                                     
01479300       GENBR(BRUN,ELSELABEL);                                                       
01479400     END ELSE BEGIN                                                                 
01479500       IF (FINTS-I=1) THEN BEGIN                                                    
01479600         GENBR(BRUN,CSSTART(LPTR));                                                 
01479700       END ELSE BEGIN                                                               
01479800         GENTREE(FINTS-I,LPTR,FPTR2,(CSLAB(LPTR)=CSLAB(LPTR2)+1));                  
01479900       END;                                                                         
01480000     END;                                                                           
01480100   END ELSE BEGIN                                                                   
01480200     GENBR(BRTR,CSSTART(LPTR2));                                                    
01480300     GENBR(BRUN,ELSELABEL);                                                         
01480400   END;                                                                             
01480500 END;                                                                               
01480600 END;   %OF GENTREE                                                                 
01480700                                                                                    
01480800   EXPRESSION(FSYS OR COMMACOLONOFSET);                                             
01480900   LOADV;                                                                           
01481000   BUILDJUMPLAB:=MAKELABEL; GENBR(BRUN,BUILDJUMPLAB);                               
01481100   LSP:=GTYPTR;                                                                     
01481200   IF (LSP NEQ NIL) THEN BEGIN                                                      
01481300     IF (FORM(LSP) > SUBRANGE) OR (LSP = REALPTR) THEN BEGIN                        
01481400       ERROR(2670); LSP:=NIL;                                                       
01481500     END ELSE BEGIN                                                                 
01481600       IF (SCALKIND(LSP) = DECLARED) THEN BEGIN                                     
01481700         RMAX:=VALUES(FCONST(LSP)); FINITETYPE:=TRUE;                               
01481800       END ELSE IF (LSP = CHARPTR) THEN BEGIN                                       
01481900         RMAX:=255; FINITETYPE:=TRUE;                                               
01482000       END ELSE BEGIN                                                               
01482100         FINITETYPE:=FALSE;                                                         
01482200       END;                                                                         
01482300     END;                                                                           
01482400   END;                                                                             
01482500   IF (SYMBOL = OFSY) THEN INSYMBOL ELSE ERROR(2671);                               
01482600   FSTPTR:=NIL; EXITLABEL:=MAKELABEL; ELSELABEL:=EXITLABEL;                         
01482700   IF (FORM(LSP)=SUBRANGE) THEN BEGIN                                               
01482800     LSPEXPR:=LSP;                                                                  
01482900     LSP:=RANGETYPE(LSP);                                                           
01483000   END;                                                                             
01483100   DO BEGIN                                                                         
01483200     LPT3:=NIL; CASELABEL:=MAKELABEL;                                               
01483300     LSP1:=LSP;                                                                     
01483400     DO BEGIN                                                                       
01483500  $SET OMIT = OTHERWISE                                                             
01483600       IF (SYMBOL = ELSESY) THEN BEGIN                                              
01483700         IF (ELSELABEL NEQ EXITLABEL) THEN ERROR(2678);                             
01483800         IF STANDARDTOG THEN BEGIN                                                  
01483900           ERROR(1677);                                                             
01484000         END;                                                                       
01484100         ELSELABEL:=CASELABEL;                                                      
01484200         INSYMBOL;                                                                  
01484300       END ELSE BEGIN                                                               
01484400  $POP OMIT                                                                         
01484500         CONSTANT((FSYS OR COMMACOLONSET),LSP,LVALUE);                              
01484600         IF (LSP NEQ NIL) THEN BEGIN                                                
01484700           IF (LSP=REALPTR) THEN BEGIN                                              
01484800             ERROR(2670); LSP:=NIL;                                                 
01484900  $SET OMIT = NOT NAMECOMP                                                          
01485000           END ELSE IF IDENTCOMPTYPES(LSP,LSP1) THEN BEGIN                          
01485100  $POP OMIT                                                                         
01485200  $SET OMIT = NAMECOMP                                                              
01485300           END ELSE IF COMPTYPES(LSP,LSP1) THEN BEGIN                               
01485400  $POP OMIT                                                                         
01485500             IF (FORM(LSPEXPR)=SUBRANGE) THEN BEGIN                                 
01485600               IF (LVALUE<SMIN(LSPEXPR)) OR (LVALUE>SMAX(LSPEXPR)) THEN             
01485700               BEGIN                                                                
01485800                 ERROR(1679);                                                       
01485900               END;                                                                 
01486000             END;                                                                   
01486100             LPT1:=FSTPTR; LPT2:=NIL;                                               
01486200             WHILE (LPT1 NEQ NIL) DO BEGIN                                          
01486300               IF (CSLAB(LPT1) <= LVALUE) THEN BEGIN                                
01486400                 IF (CSLAB(LPT1) = LVALUE) THEN ERROR(2672);                        
01486500                 GOTO FOUNDLABELPLACE;                                              
01486600               END;                                                                 
01486700               LPT2:=LPT1; LPT1:=CSNEXT(LPT1);                                      
01486800             END; % OF WHILE                                                        
01486900 FOUNDLABELPLACE:                                                                   
01487000             NEW(LPT3,CASEINFOSIZE);                                                
01487100             CSNEXT(LPT3):=LPT1; CSLAB(LPT3):=LVALUE;                               
01487200             CSSTART(LPT3):=CASELABEL;                                              
01487300             IF (LPT2 = NIL) THEN FSTPTR:=LPT3 ELSE CSNEXT(LPT2):=LPT3;             
01487400           END ELSE BEGIN                                                           
01487500             ERROR(2673);                                                           
01487600           END;                                                                     
01487700         END;                                                                       
01487800  $SET OMIT = OTHERWISE                                                             
01487900       END; % OF IF SYMBOL = ELSESY                                                 
01488000  $POP OMIT                                                                         
01488100       TEST:=(SYMBOL NEQ COMMA);                                                    
01488200       IF NOT TEST THEN INSYMBOL;                                                   
01488300     END UNTIL TEST;                                                                
01488400     IF (SYMBOL = COLON) THEN INSYMBOL ELSE ERROR(2674);                            
01488500     GENLABEL(CASELABEL);                                                           
01488600     DO BEGIN                                                                       
01488700  $SET OMIT = OTHERWISE                                                             
01488800       STATEMENT(FSYS OR SEMICOLONSET);                                             
01488900  $POP OMIT                                                                         
01489000  $SET OMIT = NOT OTHERWISE                                                         
01489100       STATEMENT(FSYS OR SEMICOLONSET OR ELSESET);                                  
01489200  $POP OMIT                                                                         
01489300     END UNTIL NOT SYMBOLIN(STATBEGSYS);                                            
01489400     GENBR(BRUN,EXITLABEL);                                                         
01489500     TEST:=(SYMBOL NEQ SEMICOLON);                                                  
01489600     IF NOT TEST THEN INSYMBOL;                                                     
01489700  $SET OMIT = OTHERWISE                                                             
01489800   END UNTIL TEST OR (SYMBOL = ENDSY);                                              
01489900  $POP OMIT                                                                         
01490000  $SET OMIT = NOT OTHERWISE                                                         
01490100   END UNTIL TEST OR (SYMBOL=ENDSY) OR                                              
01490200     ((SYMBOL=ELSESY) AND (OP=OTHERWISEOP));                                        
01490300  $POP  OMIT                                                                        
01490400  $SET OMIT = OTHERWISE                                                             
01490500   IF (ELSELABEL = EXITLABEL) THEN BEGIN                                            
01490600  $POP OMIT                                                                         
01490700  $SET OMIT = NOT OTHERWISE                                                         
01490800   IF ((SYMBOL=ELSESY) AND (OP=OTHERWISEOP)) THEN BEGIN                             
01490900     IF STANDARDTOG THEN BEGIN                                                      
01491000       ERROR(1677);                                                                 
01491100     END;                                                                           
01491200     ELSELABEL:=MAKELABEL; GENLABEL(ELSELABEL);                                     
01491300     INSYMBOL;                                                                      
01491400     DO BEGIN                                                                       
01491500       STATEMENT(FSYS OR SEMICOLONSET);                                             
01491600       TEST:=(SYMBOL NEQ SEMICOLON);                                                
01491700       IF NOT TEST THEN INSYMBOL;                                                   
01491800     END UNTIL TEST;                                                                
01491900     GENBR(BRUN,EXITLABEL);                                                         
01492000   END ELSE BEGIN                                                                   
01492100  $POP OMIT                                                                         
01492200     ELSELABEL:=MAKELABEL; GENLABEL(ELSELABEL);                                     
01492300     RUNTIMEERROR(NOCASELABERROR);                                                  
01492400   END;                                                                             
01492500   GENLABEL(BUILDJUMPLAB);                                                          
01492600   IF (FSTPTR NEQ NIL) THEN BEGIN                                                   
01492700     LMAX:=CSLAB(FSTPTR);                                                           
01492800     LPT1:=FSTPTR; FSTPTR:=NIL;                                                     
01492900     DO BEGIN                                                                       
01493000       LPT2:=CSNEXT(LPT1); CSNEXT(LPT1):=FSTPTR;                                    
01493100       FSTPTR:=LPT1; LPT1:=LPT2;                                                    
01493200     END UNTIL (LPT1 = NIL);                                                        
01493300     LMIN:=CSLAB(FSTPTR);                                                           
01493400 %       COUNT THE NUMBER OF INTERVALS                                              
01493500     NOINTS := IF(LMIN=-MAXINT) THEN 1 ELSE 2;                                      
01493600     CURRVAL := LMIN;                                                               
01493700     LPT2 := FSTPTR;                                                                
01493800     LPT1 := CSNEXT(FSTPTR);                                                        
01493900     WHILE (LPT1 NEQ NIL) DO BEGIN                                                  
01494000       IF (CSLAB(LPT1) = (CURRVAL+1)) THEN BEGIN                                    
01494100         IF(CSSTART(LPT2) NEQ CSSTART(LPT1)) THEN BEGIN                             
01494200           NOINTS := NOINTS+1;                                                      
01494300         END;                                                                       
01494400       END ELSE BEGIN                                                               
01494500         NOINTS := NOINTS +2;                                                       
01494600       END;                                                                         
01494700       CURRVAL := CSLAB(LPT1);                                                      
01494800       LPT2 := LPT1;                                                                
01494900       LPT1 := CSNEXT(LPT1);                                                        
01495000     END;                                                                           
01495100     IF (CURRVAL NEQ MAXINT) THEN BEGIN                                             
01495200       NOINTS := NOINTS +1;                                                         
01495300     END;                                                                           
01495400 %      MAKE THE DECISION WHICH CODE TO USE                                         
01495500    IF((9.5*NOINTS) < (24.5+3*(LMAX-LMIN))) THEN BEGIN                              
01495600 %      COMPARISON TREE                                                             
01495700       GENV(NAMC,LEXLEVEL,LC);                                                      
01495800       GENOP(STON);                                                                 
01495900       CASETEMP := LC;                                                              
01496000       LC := LC+1;                                                                  
01496100       IF (LC>LCMAX) THEN LCMAX := LC;                                              
01496200       ONSTACK := TRUE;                                                             
01496300       GENTREE(NOINTS,FSTPTR,LPT2,(CSLAB(FSTPTR)=-MAXINT));                         
01496400     END ELSE BEGIN                                                                 
01496500 %      JUMP TABLE                                                                  
01496600       IF (LMAX-LMIN < 1000) THEN BEGIN                                             
01496700         BUILDJUMPLAB:=MAKELABEL;                                                   
01496800         IF (LMIN NEQ 0) THEN BEGIN                                                 
01496900           IF (LMIN < 0) THEN BEGIN                                                 
01497000             GENLIT(-LMIN); GENOP(ADD);                                             
01497100           END ELSE BEGIN                                                           
01497200             GENLIT(LMIN); GENOP(SUBT);                                             
01497300           END;                                                                     
01497400         END;                                                                       
01497500         GENOP(NTGR); GENOP(DUPL);                                                  
01497600         GENHALFWORDADDRESS(BUILDJUMPLAB);                                          
01497700         GENOP(ADD); GENOP(EXCH); GENOP(DUPL);                                      
01497800         GENOP(ZERO); GENOP(LESS); GENOP(EXCH);                                     
01497900         GENLIT(LMAX-LMIN); GENOP(GRTR); GENOP(LOR);                                
01498000         GENOP(EXCH); GENOP(DBFL); GENBR(BRUN,ELSELABEL);                           
01498100         WORDBOUNDARY;                                                              
01498200         GENLABEL(BUILDJUMPLAB);                                                    
01498300         DO BEGIN                                                                   
01498400           WHILE (CSLAB(FSTPTR) > LMIN) DO BEGIN                                    
01498500             GENBR(BRUN,ELSELABEL); LMIN:=LMIN+1;                                   
01498600           END;                                                                     
01498700           GENBR(BRUN,CSSTART(FSTPTR));                                             
01498800           FSTPTR:=CSNEXT(FSTPTR); LMIN:=LMIN+1;                                    
01498900         END UNTIL (FSTPTR = NIL);                                                  
01499000         WHILE (LMIN < LMAX) DO BEGIN                                               
01499100           GENBR(BRUN,ELSELABEL); LMIN:=LMIN+1;                                     
01499200         END;                                                                       
01499300         WORDBOUNDARY;                                                              
01499400       END ELSE BEGIN                                                               
01499500         ERROR(2675);                                                               
01499600       END;                                                                         
01499700     END;                                                                           
01499800   END; % OF IF (FSTPTR NEQ NIL)                                                    
01499900   GENLABEL(EXITLABEL);                                                             
01500000   IF (SYMBOL = ENDSY) THEN INSYMBOL ELSE ERROR(2676);                              
01500100 END;% OF CASESTATEMENT                                                             
01500200                                                                                    
01500300                                                                                    
01500400 PROCEDURE WITHSTATEMENT;                                                           
01500500 %         *************                                                            
01500600 BEGIN                                                                              
01500700   TYPEIDENTPTR LIP;                                                                
01500800   INTEGER TOPSAVE,SAVELC;                                                          
01500900   %                                                                                
01501000   TOPSAVE:=TOP;                                                                    
01501100   SAVELC:=LC;                                                                      
01501200   DO BEGIN                                                                         
01501300     IF (SYMBOL = IDENT) THEN BEGIN                                                 
01501400       SEARCHID((FALSE & SETB(VARS) & SETB(FIELD)),LIP);                            
01501500       INSYMBOL;                                                                    
01501600     END ELSE BEGIN                                                                 
01501700       ERROR(2660); LIP:=UVARPTR;                                                   
01501800     END;                                                                           
01501900     SELECTOR((FSYS & SETB(COMMA) & SETB(DOSY)),LIP);                               
01502000     IF (GTYPTR NEQ NIL) THEN BEGIN                                                 
01502100       IF (FORM(GTYPTR) = RECORDS) THEN BEGIN                                       
01502200         IF (TOP < MAXTOP) THEN BEGIN                                               
01502300           TOP:=TOP+DISPLAYSIZE;                                                    
01502400           FNAME(TOP):=FSTFLD(GTYPTR);                                              
01502500           FLABEL(TOP):=NIL;                                                        
01502600           IF (GACCESS = INDRCT) THEN BEGIN                                         
01502700             OCCUR(TOP):=CREC;                                                      
01502800             CLEV(TOP):=GVLEVEL; CDSPL(TOP):=GDPLMT;                                
01502900             CINDX(TOP):=GIDPLMT;                                                   
01503000           END ELSE IF (GACCESS = INXD) THEN BEGIN                                  
01503100             IF (GIDPLMT NEQ 0) THEN BEGIN                                          
01503200               IF (GIDPLMT > 0) THEN BEGIN                                          
01503300                 GENLIT(GIDPLMT); GENOP(ADD);                                       
01503400               END ELSE BEGIN                                                       
01503500                 GENLIT(-GIDPLMT); GENOP(SUBT);                                     
01503600               END;                                                                 
01503700             END;                                                                   
01503800             GENV(NAMC,LEXLEVEL,LC); GENOP(STOD);                                   
01503900             OCCUR(TOP):=VREC;                                                      
01504000             VDLEV(TOP):=GVLEVEL; VDDSPL(TOP):=GDPLMT;                              
01504100             VLL(TOP):=LEXLEVEL;                                                    
01504200             VDLC(TOP):=LC; LC:=LC+1;                                               
01504300             IF (LC > LCMAX) THEN LCMAX:=LC;                                        
01504400           END ELSE BEGIN                                                           
01504500             ERROR(3664);                                                           
01504600           END;                                                                     
01504700         END ELSE BEGIN                                                             
01504800           ERROR(4661);                                                             
01504900         END;                                                                       
01505000       END ELSE BEGIN                                                               
01505100         ERROR(2662);                                                               
01505200       END;                                                                         
01505300     END;                                                                           
01505400     TEST:=(SYMBOL NEQ COMMA);                                                      
01505500     IF NOT TEST THEN INSYMBOL;                                                     
01505600   END UNTIL TEST;                                                                  
01505700   IF (SYMBOL = DOSY) THEN INSYMBOL ELSE ERROR(2663);                               
01505800   STATEMENT(FSYS);                                                                 
01505900   TOP:=TOPSAVE;                                                                    
01506000   IF (LC>DECLAREDLC) THEN BEGIN                                                    
01506100     IF (SAVELC >= DECLAREDLC) THEN LC:=SAVELC;                                     
01506200   END;                                                                             
01506300 END; % OF WITH STATEMENT                                                           
01506400                                                                                    
01506500                                                                                    
01506600 %         *************                                                            
01506700 % BODY OF * STATEMENT *                                                            
01506800 %         *************                                                            
01506900   IF (NOT LISTPROC) THEN                                                           
01507000   IF (SYMBOL = INTCONST) THEN BEGIN                                                
01507100     IF (VAL <= 9999) THEN BEGIN                                                    
01507200       LLTOP:=TOP;                                                                  
01507300       WHILE(OCCUR(LLTOP) NEQ BLCK) DO BEGIN                                        
01507400         LLTOP:=LLTOP-DISPLAYSIZE;                                                  
01507500       END;                                                                         
01507600       LABELRECPTR:=FLABEL(LLTOP);                                                  
01507700       WHILE (LABELRECPTR NEQ NIL) DO BEGIN                                         
01507800         IF (LABVAL(LABELRECPTR) = VAL) THEN BEGIN                                  
01507900           IF BOOLEAN(DEFINED(LABELRECPTR)) THEN ERROR(2694);                       
01508000           GENLABEL(LABNAME(LABELRECPTR));                                          
01508100           DEFINED(LABELRECPTR):=REAL(TRUE);                                        
01508200           BUILDVAL(STACKPCW(LABELRECPTR)) :=                                       
01508300             ASKFORPCW(LABNAME(LABELRECPTR));                                       
01508400           GOTO FOUNDLABEL;                                                         
01508500         END ELSE BEGIN                                                             
01508600           LABELRECPTR:=NEXTLAB(LABELRECPTR);                                       
01508700         END;                                                                       
01508800       END; % OF WHILE                                                              
01508900       ERROR(2691);                                                                 
01509000     END ELSE BEGIN                                                                 
01509100       ERROR(2690);                                                                 
01509200     END;                                                                           
01509300 FOUNDLABEL:                                                                        
01509400     INSYMBOL;                                                                      
01509500     IF (SYMBOL = COLON) THEN INSYMBOL ELSE ERROR(2695);                            
01509600   END; % OF IF TREATING LABELS                                                     
01509700   IF NOT SYMBOLIN(FSYS OR IDENTSET OR LPARENTSET) THEN BEGIN                       
01509800     ERROR(2692); SKIP(FSYS);                                                       
01509900   END;                                                                             
01510000   IF (NOT LISTPROC AND SYMBOLIN(STATBEGSYS OR IDENTSET)) OR                        
01510100     (LISTPROC AND SYMBOLIN(STATBEGSYS OR CONSTBEGSYS OR LPARENTSET))               
01510200     THEN BEGIN                                                                     
01510300     READFUNCTION := FALSE;                                                         
01510400     CASE SYMBOL OF BEGIN                                                           
01510500       %                                                                            
01510600     IDENT:                                                                         
01510700       IF LISTPROC THEN SEARCHID(VARFIELDFNCPRCSET OR KONSTSET,                     
01510800         IDENTIFIERPTR)                                                             
01510900       ELSE SEARCHID(VARFIELDFNCPRCSET,IDENTIFIERPTR);                              
01511000       IF LISTPROC THEN BEGIN                                                       
01511100         IF READWRITESTMT THEN BEGIN                                                
01511200           INSYMBOL;                                                                
01511300         END ELSE BEGIN                                                             
01511400           IF (KLASS(IDENTIFIERPTR) = PROC) THEN BEGIN                              
01511500             INSYMBOL;                                                              
01511600           END;                                                                     
01511700         END;                                                                       
01511800       END ELSE BEGIN                                                               
01511900         INSYMBOL;                                                                  
01512000       END;                                                                         
01512100       IF (KLASS(IDENTIFIERPTR) = PROC) THEN BEGIN                                  
01512200         IF (PFDECLKIND(IDENTIFIERPTR) = STANDARD) THEN BEGIN                       
01512300           CALLSTANDARD(FSYS,IDENTIFIERPTR);                                        
01512400         END ELSE BEGIN                                                             
01512500           CALLNONSTANDARD(FSYS,IDENTIFIERPTR);                                     
01512600         END;                                                                       
01512700       END ELSE BEGIN                                                               
01512800         IF LISTPROC THEN IOLISTELEMENT(IDENTIFIERPTR)                              
01512900         ELSE ASSIGNMENT(IDENTIFIERPTR,FALSE);                                      
01513000       END;                                                                         
01513100     BEGINSY:                                                                       
01513200       INSYMBOL; COMPOUNDSTATEMENT;                                                 
01513300     GOTOSY:                                                                        
01513400       INSYMBOL; GOTOSTATEMENT;                                                     
01513500     IFSY:                                                                          
01513600       INSYMBOL; IFSTATEMENT;                                                       
01513700     CASESY:                                                                        
01513800       INSYMBOL; CASESTATEMENT;                                                     
01513900     WHILESY:                                                                       
01514000       INSYMBOL; WHILESTATEMENT;                                                    
01514100     REPEATSY:                                                                      
01514200       INSYMBOL; REPEATSTATEMENT;                                                   
01514300     FORSY:                                                                         
01514400       INSYMBOL; FORSTATEMENT;                                                      
01514500     WITHSY:                                                                        
01514600       INSYMBOL; WITHSTATEMENT;                                                     
01514700     ADDOP:INTCONST:REALCONST:STRINGCONST:LPARENT:                                  
01514800       IDENTIFIERPTR:=UCSTPTR;                                                      
01514900       IOLISTELEMENT(IDENTIFIERPTR);                                                
01515000       %                                                                            
01515100     END; % OF CASE                                                                 
01515200     IF NOT SYMBOLIN(SEMICOLONENDELSEUNTILSET) AND NOT LISTPROC THEN                
01515300     BEGIN                                                                          
01515400       ERROR(2693); SKIP(FSYS);                                                     
01515500     END;                                                                           
01515600   END;                                                                             
01515700 END; % OF STATEMENT                                                                
01515800                                                                                    
01515900                                                                                    
01516000                                                                                    
01516100                                                                                    
01516200   %         ********                                                               
01516300   % BODY OF * BODY *                                                               
01516400   %         ********                                                               
01516500   TAGINDX:=-1;                                                                     
01516600   ENTRYPOINT:=MAKELABEL;                                                           
01516700   BODYPLACE:=MAKELABEL; GENLABEL(BODYPLACE);                                       
01516800   IF (FPROCP = NIL) THEN BEGIN                                                     
01516900     IF BINDINFOTOG THEN BEGIN                                                      
01517000       FIRSTEXECCODE := 0 & SEGNUMBER BSEGMENT                                      
01517100                          & (SEGWORDINDEX-SEGMENTBASE) WORDOFFSET                   
01517200                          & SEGSYLINDEX BYTEOFFSET                                  
01517300                          & LEXLEVEL BLL;                                           
01517400     END;                                                                           
01517500   END;                                                                             
01517600   TAGSIXWORD := 0;                                                                 
01517700   IF (LEXLEVEL = 2) THEN BEGIN                                                     
01517800     % STATISTICS FOR LL=2 MUST BE DELAYED AFTER STACK BUILDING                     
01517900     IF STATISTICSFLAG THEN BEGIN                                                   
01518000       STATISTICSCODE(0,SDISP);                                                     
01518100     END;                                                                           
01518200   END ELSE BEGIN                                                                   
01518300     % SCAN PARAMETER LIST FOR RECORDS/ARRAYS                                       
01518400     % IN CASE VALUE COPYING REQUIRED                                               
01518500     NXT := NEXT(FPROCP);                                                           
01518600     WHILE (NXT NEQ NIL) DO BEGIN                                                   
01518700       LSP := IDTYPE(NXT);                                                          
01518800       IF (LSP NEQ NIL) THEN BEGIN                                                  
01518900         IF (VKIND(NXT) = ACTUAL) AND (FORM(LSP) > POWER OR LONGSET(LSP))           
01519000           THEN BEGIN                                                               
01519100           %BUILD UP A VIRGIN DESCRIPTOR                                            
01519200           FSIZE := SWORDS(LSP);                                                    
01519300           BCHARSIZE:=IF(PACKED(LSP)=UNPACKEDSTRUC) THEN 0                          
01519400                     ELSE IF(BITS(LSP)=48) OR (BITS(LSP)=1) THEN 0                  
01519500                          ELSE (BITS(LSP)/2);                                       
01519600           GENLIT(0 & FSIZE[39:20]                                                  
01519700                    & BCHARSIZE [42:3]                                              
01519800                    & (IF (FSIZE>512) THEN 1 ELSE 0)[44:1]);                        
01519900           GENOP1(LT8,5);  GENOP(STAG);                                             
01520000           GENV(NAMC,LEXLEVEL,VADDR(NXT));  GENOP(OVRD);                            
01520100           % LETS NOT FORGET IT                                                     
01520200           TAGSIXFLAG := TRUE;  TAGSIXWORD := * & 1[11:1];                          
01520300           ARRAYCELLS[LEXLEVEL] := * + FSIZE;    %CODE ESTIMATE                     
01520400           % TRANSFERS A COPY                                                       
01520500           GENOP(ZERO);  GENV(NAMC,LEXLEVEL,VADDR(NXT));                            
01520600           GENOP(INDX);                                                             
01520700           GENV(NAMC,LEXLEVEL,VADDR(NXT)+1);  GENOP(LOAD);                          
01520800           GENLIT(FSIZE);                                                           
01520900           IF (BCHARSIZE=0) THEN BEGIN                                              
01521000             GENOP(TWSD);                                                           
01521100           END ELSE BEGIN                                                           
01521200             GENOP(TUND);                                                           
01521300           END;                                                                     
01521400         END;                                                                       
01521500       END;                                                                         
01521600       NXT := NEXT(NXT);                                                            
01521700     END;    % OF WHILE                                                             
01521800   END;                                                                             
01521900   DO BEGIN                                                                         
01522000     DO BEGIN                                                                       
01522100       STATEMENT(FSYS OR SEMICOLONENDSET);                                          
01522200     END UNTIL NOT SYMBOLIN(STATBEGSYS);                                            
01522300     TEST:=(SYMBOL NEQ SEMICOLON);                                                  
01522400     IF NOT TEST THEN INSYMBOL;                                                     
01522500   END UNTIL TEST;                                                                  
01522600   IF (SYMBOL = ENDSY) THEN INSYMBOL ELSE ERROR(2520);                              
01522700   % TEST FOR UNSITED LABELS                                                        
01522800   LLP:=FLABEL(TOP);                                                                
01522900   WHILE (LLP NEQ NIL) DO BEGIN                                                     
01523000     IF NOT BOOLEAN(DEFINED(LLP)) THEN BEGIN                                        
01523100       ERROR(2521);                                                                 
01523200       GENLABEL(LABNAME(LLP));                                                      
01523300       REPLACE LBUF0 BY "LABEL ",                                                   
01523400                        (LABVAL(LLP)) FOR 4 DIGITS;                                 
01523500       WRITEBUFFER;                                                                 
01523600     END;                                                                           
01523700     LLP:=NEXTLAB(LLP);                                                             
01523800   END; % OF WHILE                                                                  
01523900   TRAVERSETREE(FNAME(TOP));                                                        
01524000   IF (LEXLEVEL=BASELVL) THEN BEGIN                                                 
01524100   % FLUSH FILE OUTPUT                                                              
01524200   % DONT WORRY ABOUT INPUT                                                         
01524300     GENOP1(LT8,6);                                                                 
01524400     GENV(VALC,BASELVL,ADDROFILEDATA);                                              
01524500     GENOP(ZERO);                                                                   
01524600     GENOP(EQUL);                                                                   
01524700     LAB:=MAKELABEL;                                                                
01524800     GENBR(BRTR,LAB);                                                               
01524900     GENOP(ONE);  GENV(VALC,BASELVL,ADDROFILEDATA);                                 
01525000     GENOP2(ISOL,3,4);                                                              
01525100     GENOP1(LT8,3);  GENOP(EQUL);                                                   
01525200     GENBR(BRFL,LAB);                                                               
01525300     GENOP(MKST);                                                                   
01525400     GENV(NAMC,1,INTRINSICADDR(PASCALTEXTWRITEADDR,                                 
01525500                 PASCALINTRINSIC(PASCALTEXTWRITEINTR)));                            
01525600     GENV(NAMC,BASELVL,ADDROFILE); GENOP(STFF);                                     
01525700     GENV(NAMC,BASELVL,ADDROBUF); GENOP(LOAD);                                      
01525800     GENV(NAMC,BASELVL,ADDROFILEDATA); GENOP(LOAD);                                 
01525900     GENOP(ZERO);                                                                   
01526000     GENOP(DUPL); GENOP(DUPL); GENOP(DUPL); GENOP(DUPL);                            
01526100     GENLIT(7 & 1[47:1]);                                                           
01526200     GENOP(ENTR);                                                                   
01526300     GENLABEL(LAB);                                                                 
01526400   END;                                                                             
01526500   % CLOSE TIMING                                                                   
01526600   IF STATISTICSFLAG THEN BEGIN                                                     
01526700     STATISTICSCODE(1,SDISP);                                                       
01526800   END;                                                                             
01526900   % GENERATE EXIT                                                                  
01527000   IF TAGSIXFLAG THEN BEGIN                                                         
01527100     IF (FPROCP=NIL) THEN BEGIN                                                     
01527200       IF BINDINFOTOG THEN BEGIN                                                    
01527300         BEXITPTR := 0 & SEGNUMBER BSEGMENT                                         
01527400                       & (SEGWORDINDEX-SEGMENTBASE) WORDOFFSET                      
01527500                       & SEGSYLINDEX BYTEOFFSET                                     
01527600                       & LEXLEVEL BLL;                                              
01527700       END;                                                                         
01527800       MPCWP(OBPROCP).CODEPAGE:=SEGNUMBER;                                          
01527900     END;                                                                           
01528000     GENOP(MKST);                                                                   
01528100     GENV(NAMC,0,10);                                                               
01528200     GENOP(ENTR);                                                                   
01528300   END;                                                                             
01528400   IF (FPROCP NEQ NIL) THEN BEGIN                                                   
01528500     IF (IDTYPE(FPROCP) = NIL) THEN BEGIN                                           
01528600       GENOP(EXIT);                                                                 
01528700     END ELSE BEGIN                                                                 
01528800       GENV(VALC,LEXLEVEL,FNCDPLMT(FPROCP));                                        
01528900       GENOP(RETN);                                                                 
01529000     END;                                                                           
01529100     MPCWP(FPROCP) := SEGNUMBER;                                                    
01529200   END ELSE BEGIN                                                                   
01529300     GENOP(EXIT);                                                                   
01529400   END;                                                                             
01529500   IF LCODE THEN BEGIN                                                              
01529600     REPLACE LBUF[35] BY "=====STACK BUILDING CODE (LEX LEVEL = ",                  
01529700                         LEXLEVEL FOR DIGITSIN(LEXLEVEL) DIGITS,                    
01529800                         ", ENTRY AT NEXT LABEL)=====";                             
01529900     WRITELBUFFER;                                                                  
01530000   END;                                                                             
01530100   % SITE ENTRYLABEL                                                                
01530200   GENLABEL(ENTRYPOINT);                                                            
01530300   % START STATISTICS TIMING AND COUNTER                                            
01530400   IF STATISTICSFLAG AND (LEXLEVEL NEQ 2) THEN BEGIN                                
01530500     STATISTICSCODE(0,SDISP);                                                       
01530600   END;                                                                             
01530700   % GENERATE STACK BUILDING CODE                                                   
01530800   STACKBUILDPTR:=STACKHEADP;                                                       
01530900   LASTKIND := -1;                                                                  
01531000   IF (STACKBUILDPTR NEQ NIL) THEN BEGIN                                            
01531100     LCT:=ENTRYLC;                                                                  
01531200     WHILE (STACKBUILDPTR NEQ NIL) DO BEGIN                                         
01531300       CASE BUILDKIND(STACKBUILDPTR) OF BEGIN                                       
01531400         %                                                                          
01531500       ONEWORD:                                                                     
01531600         IF TRUSTWORTHYTOG THEN BEGIN                                               
01531700           GENOP(ZERO);                                                             
01531800         END ELSE BEGIN                                                             
01531900           IF (LASTKIND=ONEWORD) THEN BEGIN                                         
01532000             GENOP(DUPL);                                                           
01532100           END ELSE BEGIN                                                           
01532200             GENOP(ZERO);  GENOP1(LT8,6);  GENOP(STAG);                             
01532300           END;                                                                     
01532400         END;                                                                       
01532500       DOUBLEWORD:                                                                  
01532600         IF (LASTKIND=DOUBLEWORD) THEN BEGIN                                        
01532700           GENOP(DUPL);                                                             
01532800         END ELSE BEGIN                                                             
01532900           GENOP(ZERO);  GENOP(XTND);                                               
01533000         END;                                                                       
01533100       ARRAYDESCRIPTOR:                                                             
01533200         GENLIT(BUILDVAL(STACKBUILDPTR));                                           
01533300         GENOP1(LT8,5); GENOP(STAG);                                                
01533400         TAGSIXWORD:= * & 1 [11:1];                                                 
01533500       FPBDESCRIPTOR:                                                               
01533600         IF BINDINFOTOG THEN BEGIN                                                  
01533700           BITPICKER := 0 & SEGNUMBER BSEGMENT                                      
01533800                          & (SEGWORDINDEX-SEGMENTBASE) WORDOFFSET                   
01533900                          & SEGSYLINDEX BYTEOFFSET;                                 
01534000           FIBPTRS[FIBPTR] := BITPICKER;                                            
01534100           FIBPTR := *+1;                                                           
01534200         END;                                                                       
01534300         GENLIT(BUILDVAL(STACKBUILDPTR));                                           
01534400         GENOP1(LT8,5); GENOP(STAG);                                                
01534500         TAGINDX:=*+1;                                                              
01534600         IF(TAGINDX>=MAXFILES) THEN ERROR(4523);                                    
01534700         TAG4WORDS[TAGINDX]:=LCT+2;                                                 
01534800         TAGSIXWORD:= * & 1 [13:1];                                                 
01534900       PCWWORD:                                                                     
01535000         IF BINDINFOTOG THEN BEGIN                                                  
01535100           IF (BUILDID(STACKBUILDPTR) = NIL) THEN BEGIN                             
01535200             GENLT48(MPCW,BUILDVAL(STACKBUILDPTR));                                 
01535300           END ELSE BEGIN                                                           
01535400             BITPICKER := 0 & SEGNUMBER BSEGMENT                                    
01535500                            & (SEGWORDINDEX-SEGMENTBASE) WORDOFFSET                 
01535600                            & SEGSYLINDEX BYTEOFFSET;                               
01535700             IF(BINDIN(BUILDID(STACKBUILDPTR))=BINDITIN) THEN BEGIN                 
01535800               GENLT48(LT48,BUILDVAL(STACKBUILDPTR));                               
01535900             END ELSE BEGIN                                                         
01536000               GENLT48(MPCW,BUILDVAL(STACKBUILDPTR));                               
01536100             END;                                                                   
01536200             MPCWP(BUILDID(STACKBUILDPTR)) := BITPICKER;                            
01536300           END;                                                                     
01536400         END ELSE BEGIN                                                             
01536500           GENLT48(MPCW,BUILDVAL(STACKBUILDPTR));                                   
01536600         END;                                                                       
01536700         IF(BUILDVAL(STACKBUILDPTR)=-1) THEN ERROR(5522);                           
01536800       FUNNYSIRW:                                                                   
01536900         GENV(NAMC,1,0); GENOP(STFF); GENOP1(BSET,13);                              
01537000       ONEWORDCONSTANT:                                                             
01537100         GENLIT(BUILDVAL(STACKBUILDPTR));                                           
01537200       STATSARRAY:                                                                  
01537300         IF (LASTKIND = STATSARRAY) THEN BEGIN                                      
01537400           GENOP(DUPL);                                                             
01537500         END ELSE BEGIN                                                             
01537600           GENOP(ZERO); GENOP1(BSET,21);                                            
01537700           GENOP1(LT8,5); GENOP(STAG);                                              
01537800           TAGSIXWORD := * & 1 [11:1];                                              
01537900         END;                                                                       
01538000         %                                                                          
01538100       END; % OF CASE                                                               
01538200       IF LCODE THEN BEGIN                                                          
01538300         REPLACE LBUF[59] BY "-" FOR 6,                                             
01538400           "(", LEXLEVEL FOR 2 DIGITS,                                              
01538500           ",", LCT FOR 5 DIGITS, ")";                                              
01538600         WRITELBUFFER;                                                              
01538700       END;                                                                         
01538800       LCT:=LCT + (IF (BUILDKIND(STACKBUILDPTR) = DOUBLEWORD)                       
01538900             THEN 2 ELSE 1);                                                        
01539000       LASTKIND := BUILDKIND(STACKBUILDPTR);                                        
01539100       STACKBUILDPTR:=BUILDPTR(STACKBUILDPTR);                                      
01539200     END; % OF WHILE                                                                
01539300   END; % OF IF ANY STACKCODE                                                       
01539400   WHILE (DECLAREDLC < LCMAX) DO BEGIN                                              
01539500     IF TRUSTWORTHYTOG THEN BEGIN                                                   
01539600       GENOP(ZERO);                                                                 
01539700     END ELSE BEGIN                                                                 
01539800       IF (LASTKIND=ONEWORD) THEN BEGIN                                             
01539900         GENOP(DUPL);                                                               
01540000       END ELSE BEGIN                                                               
01540100         GENOP(ZERO);  GENOP1(LT8,6);  GENOP(STAG);                                 
01540200       END;                                                                         
01540300     END;                                                                           
01540400     IF LCODE THEN BEGIN                                                            
01540500       REPLACE LBUF[59] BY "-" FOR 6,                                               
01540600         "(", LEXLEVEL FOR 2 DIGITS,                                                
01540700         ",", DECLAREDLC FOR 5 DIGITS, ")";                                         
01540800       WRITELBUFFER;                                                                
01540900     END;                                                                           
01541000     DECLAREDLC:=DECLAREDLC+1;                                                      
01541100     LASTKIND := ONEWORD;                                                           
01541200   END;  % OF WHILE                                                                 
01541300   % IF STATISTICS WERE SET OVER ANY PROCEDURE, THEN INSERT A PROC                  
01541400   %    IN THE D2 STACK BUILDING CODE END                                           
01541500   IF ANYSTATISTICSFLAG AND (LEXLEVEL = 2) THEN BEGIN                               
01541600     % GET A LABEL AND BRANCH AROUND THE PROCEDURE                                  
01541700     RESUME := MAKELABEL; GENBR(BRUN,RESUME);                                       
01541800     % NOW START THE PROCEDURE                                                      
01541900     IF LCODE THEN BEGIN                                                            
01542000       REPLACE LBUF[59] BY ">" FOR 6,                                               
01542100         "STATIS","TICS P","ROC";                                                   
01542200       WRITELBUFFER;                                                                
01542300     END;                                                                           
01542400     LEXLEVEL:=3;                                                                   
01542500     STATSRUN := MAKELABEL; GENLABEL(STATSRUN);                                     
01542600     % SETUP INITIALIZE                                                             
01542700     GENOP(MKST);                                                                   
01542800     GENV(NAMC,1,INTRINSICADDR(TIMINGADDR,                                          
01542900         PASCALINTRINSIC(PASCALTIMING)));                                           
01543000     GENOP(ZERO);                                                                   
01543100     GENV(NAMC,2,0); GENOP(STFF);                                                   
01543200     GENOP(ZERO);                                                                   
01543300     GENOP(ENTR);                                                                   
01543400     % HANDLE EACH ENTRY IN THE STATSTABLE                                          
01543500     FOR I := 0 STEP 2 UNTIL STATSMAX DO BEGIN                                      
01543600       GENOP(MKST);                                                                 
01543700       GENV(NAMC,1,INTRINSICADDR(TIMINGADDR,                                        
01543800           PASCALINTRINSIC(PASCALTIMING)));                                         
01543900       GENLT48(LT48,STATSTABLE[I]);                                                 
01544000       GENV(NAMC,2,0); GENOP(STFF);                                                 
01544100       GENV(NAMC,2,STATSTABLE[I+1]); GENOP(LOAD);                                   
01544200       GENOP(ENTR);                                                                 
01544300     END;                                                                           
01544400     % EXIT BACK TO BLOCKEXIT                                                       
01544500     GENOP(EXIT);                                                                   
01544600     LEXLEVEL:=2;                                                                   
01544700     % RESUME STACK BUILDING CODE                                                   
01544800     IF LCODE THEN BEGIN                                                            
01544900       REPLACE LBUF[59] BY ">" FOR 6,                                               
01545000         "END PR","OC";                                                             
01545100       WRITELBUFFER;                                                                
01545200     END;                                                                           
01545300     GENLABEL(RESUME);                                                              
01545400     % NOW THE PROCEDURE PCW                                                        
01545500     GENLT48(MPCW,ASKFORPCW(STATSRUN) & 0 [47:1]);                                  
01545600     TAGSIXFLAG:=TRUE;  % IN CASE IT ISN'T ALREADY                                  
01545700     TAGSIXWORD := * & 1 [20:1];                                                    
01545800   END;                                                                             
01545900   IF BINDINFOTOG THEN BEGIN                                                        
01546000     IF (FPROCP = NIL) THEN BEGIN                                                   
01546100       ENDOFD2CODE := 0 & SEGNUMBER BSEGMENT                                        
01546200                        & (SEGWORDINDEX-SEGMENTBASE) WORDOFFSET                     
01546300                        & LEXLEVEL BLL                                              
01546400                        & SEGSYLINDEX BYTEOFFSET;                                   
01546500       SCWIMAGE := 0 & 7[13:3];                                                     
01546600     END;                                                                           
01546700   END;                                                                             
01546800   IF TAGSIXFLAG THEN BEGIN                                                         
01546900     GENLT48(LT48,(TAGSIXWORD & 1 [47:1]));                                         
01547000     GENOP1(LT8,6); GENOP(STAG);                                                    
01547100     STACKCELLS[LEXLEVEL]:=*+1;                                                     
01547200   END;                                                                             
01547300   WHILE (TAGINDX>=0) DO BEGIN                                                      
01547400     GENOP1(LT8,6);                                                                 
01547500     GENV(NAMC,LEXLEVEL,TAG4WORDS[TAGINDX]);                                        
01547600     GENOP(INDX);                                                                   
01547700     GENLIT(5 & 1[36:1] & 1[20:1]);                                                 
01547800     GENOP1(LT8,4);                                                                 
01547900     GENOP(STAG);                                                                   
01548000     GENOP(STOD);                                                                   
01548100     TAGINDX:=*-1;                                                                  
01548200   END;                                                                             
01548300   IF (TAGSIXFLAG OR (STACKHEADP NEQ NIL)) THEN GENOP(PUSH);                        
01548400   IF BINDINFOTOG THEN BEGIN                                                        
01548500     BUILDLOCALDIRECTORY(FPROCP,STACKHEADP);                                        
01548600   END;                                                                             
01548700   GENBR(BRUN,BODYPLACE);                                                           
01548800  $SET OMIT = NOT DEBUG                                                             
01548900   IF (LISTTOG AND CODETOG) THEN BEGIN                                              
01549000     REPLACE LBUF[0] BY                                                             
01549100       "TOP OF HEAP POINTER = ",                                                    
01549200       TOPOFHEAP FOR 5 DIGITS;                                                      
01549300     WRITELBUFFER;                                                                  
01549400   END;                                                                             
01549500  $POP OMIT                                                                         
01549600 END; % OF BODY                                                                     
01549700                                                                                    
01549800                                                                                    
01549900   %         *********                                                              
01550000   % BODY OF * BLOCK *                                                              
01550100   %         *********                                                              
01550200   DP:=TRUE;                                                                        
01550300   FWPTR:=STACKHEADP:=STACKTAILP:=NIL;                                              
01550400   ENTRYLC:=LC;                                                                     
01550500   ANYSTATISTICSFLAG := ANYSTATISTICSFLAG OR STATISTICSFLAG;                        
01550600   IF (LEXLEVEL = 2) THEN BEGIN                                                     
01550700   %=====================================================================           
01550800   %   SET UP BOTTOM OF STACK                                                       
01550900   %=====================================================================           
01551000     GENERATEFUNNYSIRW;  LC:=LC+1;                                                  
01551100     NEWTEMPARR(LCP);                                                               
01551200     VLEV(LCP):=2;  VADDR(LCP):=LC;                                                 
01551300     GENERATEARRAYDESCRIPTOR(HEAPSIZE,LCP);      %HEAP DESCRIPTOR                   
01551400     NEWTEMPVAR(LCP1);                                                              
01551500     VLEV(LCP1):=LEXLEVEL;  VADDR(LCP1):=LC+1;                                      
01551600     GENERATEONEWORDCONSTANT(1,LCP1);             %HEAP POINTER                     
01551700     BEGINNEWSEGMENT(INFOSEGTYPE);    %INPUT                                        
01551800     GENWORD(4"010000000000");                                                      
01551900     GENWORD(4"09010105C9D5");                                                      
01552000     GENWORD(4"D7E4E3000000");                                                      
01552100     GENWORD(4"031D04030809");                                                      
01552200     GENWORD(4"031401000000");                                                      
01552300     CLOSESEGMENT;                                                                  
01552400     GENERATEFPBDESCRIPTOR(5,STARTSEG,INPUTPTR);                                    
01552500     NEWTEMPARR(LCP);                                                               
01552600     VLEV(LCP):=BASELVL;  VADDR(LCP):=ADDRIBUF;                                     
01552700     GENERATESZDESCRIPTOR(80,4,LCP);                                                
01552800     NEWTEMPARR(LCP);                                                               
01552900     VLEV(LCP):=BASELVL;  VADDR(LCP):=ADDRIFILEDATA;                                
01553000     GENERATEARRAYDESCRIPTOR(FILEDATASIZE,LCP);                                     
01553100   %                                                                                
01553200     BEGINNEWSEGMENT(INFOSEGTYPE);    %OUTPUT                                       
01553300     GENWORD(4"010000000000");                                                      
01553400     GENWORD(4"0A010106D6E4");                                                      
01553500     GENWORD(4"E3D7E4E30000");                                                      
01553600     GENWORD(4"031D04030807");                                                      
01553700     GENWORD(4"031402000000");                                                      
01553800     CLOSESEGMENT;                                                                  
01553900     GENERATEFPBDESCRIPTOR(5,STARTSEG,OUTPUTPTR);                                   
01554000     NEWTEMPARR(LCP);                                                               
01554100     VLEV(LCP):=BASELVL;  VADDR(LCP):=ADDROBUF;                                     
01554200     GENERATESZDESCRIPTOR(132,4,LCP);                                               
01554300     NEWTEMPARR(LCP);                                                               
01554400     VLEV(LCP):=BASELVL;  VADDR(LCP):=ADDROFILEDATA;                                
01554500     GENERATEARRAYDESCRIPTOR(FILEDATASIZE,LCP);                                     
01554600   %                                                                                
01554700     LC := LC + NOOFSPECWORDS;                                                      
01554800   %                                                                                
01554900     % IS THE MAIN PROGRAM SET FOR STATISTICS?                                      
01555000     IF STATISTICSFLAG THEN BEGIN                                                   
01555100       STATSMIN := STATSMAX := STATSMAX+2;                                          
01555200       SDISP := LC;                                                                 
01555300       STATSTABLE[STATSMAX] := "-MAIN-";                                            
01555400       STATSTABLE[STATSMAX+1] := LC;                                                
01555500       LC:=LC+1;                                                                    
01555600       GENERATESTATSARRAY;                                                          
01555700     END;                                                                           
01555800   END;                                                                             
01555900   IF (FPROCP NEQ NIL) THEN BEGIN                                                   
01556000     IF (IDTYPE(FPROCP) NEQ NIL) THEN BEGIN                                         
01556100       FNCDPLMT(FPROCP):=LC; LC:=LC+1;                                              
01556200       GENERATEONEWORD(FPROCP);                                                     
01556300     END;                                                                           
01556400   END;                                                                             
01556500   DECLAREDLC:=LCMAX:=LC;                                                           
01556600   DO BEGIN                                                                         
01556700     IF (SYMBOL = LABELSY) THEN BEGIN                                               
01556800       INSYMBOL; LABELDECLARATION;                                                  
01556900     END;                                                                           
01557000     IF (SYMBOL = CONSTSY) THEN BEGIN                                               
01557100       INSYMBOL; CONSTDECLARATION;                                                  
01557200     END;                                                                           
01557300     IF (SYMBOL = TYPESY) THEN BEGIN                                                
01557400       INSYMBOL; TYPEDECLARATION;                                                   
01557500     END;                                                                           
01557600     IF (SYMBOL = VARSY) THEN BEGIN                                                 
01557700       INSYMBOL; VARDECLARATION;                                                    
01557800     END;                                                                           
01557900     IF (SYMBOL = FORMATSY) THEN BEGIN                                              
01558000       IF STANDARDTOG THEN BEGIN                                                    
01558100         ERROR(1513);                                                               
01558200       END;                                                                         
01558300       INSYMBOL; FORMATDECLARATION;                                                 
01558400     END;                                                                           
01558500     DECLAREDLC := LCMAX := LC;                                                     
01558600     WHILE SYMBOLIN(PROCFUNCSET) DO BEGIN                                           
01558700       LSY:=SYMBOL; INSYMBOL; PROCDECLARATION(LSY);                                 
01558800     END;                                                                           
01558900     IF (SYMBOL NEQ BEGINSY) THEN BEGIN                                             
01559000       ERROR(2510); SKIP(FSYS);                                                     
01559100     END;                                                                           
01559200   END UNTIL SYMBOLIN(STATBEGSYS);                                                  
01559300   DP:=FALSE;                                                                       
01559400   DECLAREDLC:=LCMAX:=LC;                                                           
01559500   IF (SYMBOL = BEGINSY) THEN INSYMBOL ELSE ERROR(2511);                            
01559600   DO BEGIN                                                                         
01559700     BODY((FSYS OR CASESET),ENTRYPOINT);                                            
01559800     IF (SYMBOL NEQ FSY) THEN BEGIN                                                 
01559900       ERROR(2512);                                                                 
01560000       SKIP(FSYS & TRUE [FSY:1]);                                                   
01560100     END;                                                                           
01560200   END UNTIL (SYMBOL=FSY) OR SYMBOLIN(BLOCKBEGSYS);                                 
01560300   IF NAMESTOG THEN PRINTTABLES(FALSE);                                             
01560400   IF BINDINFOTOG THEN BEGIN                                                        
01560500     IF (FPROCP = NIL) THEN BEGIN                                                   
01560600       BUILDPROCEDUREDIRECTORY(OBPROCP);                                            
01560700     END ELSE BEGIN                                                                 
01560800       BUILDPROCEDUREDIRECTORY(FPROCP);                                             
01560900     END;                                                                           
01561000   END;                                                                             
01561100 END; % OF BLOCK                                                                    
01561200                                                                                    
01561300                                                                                    
01561400 % END OF BLOCKBODY *****************************************************           
01561500 PROCEDURE INITIALIZE;                                                              
01561600 %         **********                                                               
01561700 BEGIN                                                                              
01561800   %*********************************************************************           
01561900   %*                                                                               
01562000   %* THIS ROUTINE CONTAINS A TOTAL GRAB-BAG OF INITIALIZATIONS                     
01562100   %*   SOME ARE VIRTUAL CONSTANTS WHICH WILL LATER BE MODIFIED                     
01562200   %*   FOR EFFICIENCY, OR CHANGED TO DEFINES.                                      
01562300   %*   SOME ARE SETTING OF INITIAL VALUES...                                       
01562400   %*   AND SOME ARE SETTING UP INITIAL SYMBOL POINTERS/TABLES...                   
01562500   %*                                                                               
01562600   %*********************************************************************           
01562700                                                                                    
01562800 %=======================================================================           
01562900 % LOCAL DEFINITIONS AND VARIABLES (FOR ENTERING DATA)                              
01563000 %=======================================================================           
01563100                                                                                    
01563200   TYPESTRUCTPTR SP,SP1,SP2;                                                        
01563300   TYPEIDENTPTR CP,CP1;                                                             
01563400   INTEGER I,KOLD,KNEW;                                                             
01563500   POINTER P0,P1;                                                                   
01563600   %                                                                                
01563700   DEFINE                                                                           
01563800         CREATE(J)=                                                                 
01563900         BEGIN                                                                      
01564000           REPLACE P1 BY SNAME[(J)*12] FOR KNEW:KOLD UNTIL = " ", " ";              
01564100           NAMEBUF[0].[47:8]:=(LENGTH:=(KOLD-KNEW)+1);                              
01564200           NEWIDENTRECORDWITHNAME(CP);                                              
01564300         END#,                                                                      
01564400                                                                                    
01564500         PUTNAME1(J)=                                                               
01564600         BEGIN                                                                      
01564700           REPLACE POINTER(HEAP[J+OTHERIDENTSIZE]) BY P0 FOR 2;                     
01564800         END#,                                                                      
01564900                                                                                    
01565000         PUTNAME2(J)=                                                               
01565100         BEGIN                                                                      
01565200           REPLACE POINTER(HEAP[J+PROCFUNCSIZE]) BY P0 FOR 2;                       
01565300         END#;                                                                      
01565400                                                                                    
01565500   EBCDIC VALUE ARRAY SNAME(                                                        
01565600         "INTEGER     ",                                                            
01565700         "REAL        ",                                                            
01565800         "CHAR        ",                                                            
01565900         "BOOLEAN     ",                                                            
01566000         "FALSE       ",                                                            
01566100         "TRUE        ",                                                            
01566200         "NIL         ",                                                            
01566300         "MAXINT      ",                                                            
01566400                                                                                    
01566500         "ABS         ",                                                            
01566600         "SQR         ",                                                            
01566700         "TRUNC       ",                                                            
01566800         "ROUND       ",                                                            
01566900         "ODD         ",                                                            
01567000         "ORD         ",                                                            
01567100         "CHR         ",                                                            
01567200         "PRED        ",                                                            
01567300         "SUCC        ",                                                            
01567400         "EOF         ",                                                            
01567500         "EOLN        ",                                                            
01567600         "SIN         ",                                                            
01567700         "COS         ",                                                            
01567800         "ARCTAN      ",                                                            
01567900         "EXP         ",                                                            
01568000         "LN          ",                                                            
01568100         "SQRT        ",                                                            
01568200         "TAN         ",                                                            
01568300         "COTAN       ",                                                            
01568400         "ARCSIN      ",                                                            
01568500         "ARCCOS      ",                                                            
01568600         "ARCTAN2     ",                                                            
01568700         "SINH        ",                                                            
01568800         "COSH        ",                                                            
01568900         "TANH        ",                                                            
01569000         "ATANH       ",                                                            
01569100         "LOG         ",                                                            
01569200         "ERF         ",                                                            
01569300         "ERFC        ",                                                            
01569400         "GAMMA       ",                                                            
01569500         "LNGAMMA     ",                                                            
01569600         "CARD        ",                                                            
01569700         "RANDOM      ",                                                            
01569800         "MIN         ",                                                            
01569900         "MAX         ",                                                            
01570000         "ELAPSEDTIME ",                                                            
01570100         "PROCESSTIME ",                                                            
01570200         "IOTIME      ",                                                            
01570300         "ENDOFFILE   ",                                                            
01570400                                                                                    
01570500         "GET         ",                                                            
01570600         "PUT         ",                                                            
01570700         "NEW         ",                                                            
01570800         "MARK        ",                                                            
01570900         "RELEASE     ",                                                            
01571000         "READ        ",                                                            
01571100         "WRITE       ",                                                            
01571200         "HALT        ",                                                            
01571300         "TIMESTAMP   ",                                                            
01571400         "CLOSE       ",                                                            
01571500         "SEEK        ",                                                            
01571600         "SPACE       ",                                                            
01571700         "PAGE        ",                                                            
01571800         "STARTJOB    ",                                                            
01571900         "READLN      ",                                                            
01572000         "WRITELN     ",                                                            
01572100         "RESET       ",                                                            
01572200         "REWRITE     ",                                                            
01572300         "PACK        ",                                                            
01572400         "UNPACK      ",                                                            
01572500         "DISPOSE     ",                                                            
01572600         "READREC     ",                                                            
01572700         "WRITEREC    ",                                                            
01572800  $SET OMIT = NOT CODETEST                                                          
01572900         "CODE        ",                                                            
01573000  $POP OMIT                                                                         
01573100         "INPUT       ",                                                            
01573200         "OUTPUT      ",                                                            
01573300         "TEXT        "                                                             
01573400         );                                                                         
01573500                                                                                    
01573600   DEFINE                                                                           
01573700  $SET OMIT = NOT CODETEST                                                          
01573800         CODETEST=1#,                                                               
01573900  $POP OMIT                                                                         
01574000  $SET OMIT = CODETEST                                                              
01574100         CODETEST=0#,                                                               
01574200  $POP OMIT                                                                         
01574300         PROCPARAMS1 = 19#,                                                         
01574400         PROCPARAMS2 = 38#,                                                         
01574500         PROCRANDOM = 40#,                                                          
01574600         FNNAMESTART = 8#,                                                          
01574700         FNNAMESTOP = 46#,                                                          
01574800         PROCNAMESTART = 47#,                                                       
01574900         PROCNAMESTOP = 69+CODETEST#;                                               
01575000 %=======================================================================           
01575100 % SET UP BASIC POINTERS, ETC                                                       
01575200 %=======================================================================           
01575300                                                                                    
01575400   NAMEBUF0:=POINTER(NAMEBUF[0]);                                                   
01575500   NAMEBUF1:=NAMEBUF0+1;                                                            
01575600   LBUF0:=LBUF[0];                                                                  
01575700   REPLACE LBUF0 BY " " FOR 22 WORDS;                                               
01575800   INITIALIZEINSYMBOL;                                                              
01575900   REPLACE INSYP1 BY " " FOR 80;                                                    
01576000   TOPOFHEAP:=1;                                                                    
01576100   DP:=TRUE;                                                                        
01576200   PRTERR:=TRUE;                                                                    
01576300   GLOBTESTP:=NIL;                                                                  
01576400   INITIALIZEOPTIONINFO;                                                            
01576500                                                                                    
01576600 %=======================================================================           
01576700 % SET UP SET CONSTANTS                                                             
01576800 %=======================================================================           
01576900                                                                                    
01577000   PLUSMINUSSET:=FALSE & SETB(PLUS) & SETB(MINUS);                                  
01577100                                                                                    
01577200   SCALSUBPTRSET         :=FALSE & SETB(SCALAR) & SETB(SUBRANGE)                    
01577300                           & SETB(POINTERS);                                        
01577400                                                                                    
01577500   PRCSET:=FALSE & SETB(PROC);                                                      
01577600   FNCSET:=FALSE & SETB(FUNC);                                                      
01577700   PRCFNCSET:=PRCSET OR FNCSET;                                                     
01577800   KONSTSET:=FALSE & SETB(KONST);                                                   
01577900   TYPESET:=FALSE & SETB(TYPES);                                                    
01578000   TYPESKONST:=TYPESET OR KONSTSET;                                                 
01578100   KONSTVARFLDFNCSET:=KONSTSET & SETB(VARS) & SETB(FIELD) & SETB(FUNC);             
01578200   VARFIELDFNCPRCSET:=FALSE & SETB(VARS) & SETB(FIELD) & SETB(FUNC)                 
01578300                            & SETB(PROC);                                           
01578400   VARFLDSET:=FALSE & SETB(VARS) & SETB(FIELD);                                     
01578500   FORMATSET             :=FALSE & SETB(FORMATS);                                   
01578600   KONSTVARFLDFNCPRCFMTSET := VARFIELDFNCPRCSET                                     
01578700                              OR FORMATSET OR KONSTSET;                             
01578800   COLONSET:=FALSE & SETB(COLON);                                                   
01578900   SEMICOLONSET:=FALSE & SETB(SEMICOLON);                                           
01579000   ENDSET:=FALSE & SETB(ENDSY);                                                     
01579100   COMMASET:=FALSE & SETB(COMMA);                                                   
01579200   LPARENTSET:=FALSE & SETB(LPARENT);                                               
01579300   RPARENTSET:=FALSE & SETB(RPARENT);                                               
01579400   LBRACKSET:=FALSE & SETB(LBRACK);                                                 
01579500   RBRACKSET:=FALSE & SETB(RBRACK);                                                 
01579600   OFSET:=FALSE & SETB(OFSY);                                                       
01579700   IDENTSET:=FALSE & SETB(IDENT);                                                   
01579800   THENSET:=FALSE & SETB(THENSY);                                                   
01579900   CASESET:=FALSE & SETB(CASESY);                                                   
01580000   UNTILSET:=FALSE & SETB(UNTILSY);                                                 
01580100   BEGINSET:=FALSE & SETB(BEGINSY);                                                 
01580200   BECOMESSET            :=FALSE & SETB(BECOMES);                                   
01580300   TOSET                 :=FALSE & SETB(TOSY);                                      
01580400   ELSESET               :=FALSE & SETB(ELSESY);                                    
01580500   DOSET                 :=FALSE & SETB(DOSY);                                      
01580600   ADDOPSET              :=FALSE & SETB(ADDOP);                                     
01580700   MULOPSET              :=FALSE & SETB(MULOP);                                     
01580800   RELOPSET              :=FALSE & SETB(RELOP);                                     
01580900   PROCSET               :=FALSE & SETB(PROCSY);                                    
01581000   FUNCSET               :=FALSE & SETB(FUNCSY);                                    
01581100   VARSET                :=FALSE & SETB(VARSY);                                     
01581200                                                                                    
01581300   COMMACOLONSET:=COMMASET OR COLONSET;                                             
01581400   COMMARPARENTSET:=COMMASET OR RPARENTSET;                                         
01581500   IDENTCASESET:=IDENTSET OR CASESET;                                               
01581600   COMMASEMICOLONSET:=COMMASET OR SEMICOLONSET;                                     
01581700   OFLPARENTSET:=OFSET OR LPARENTSET;                                               
01581800   COMMARBRACKSET:=COMMASET OR RBRACKSET;                                           
01581900   CASESEMICOLONSET:=CASESET OR SEMICOLONSET;                                       
01582000   SEMICOLONENDSET:=SEMICOLONSET OR ENDSET;                                         
01582100   SEMICOLONUNTILSET:=SEMICOLONSET OR UNTILSET;                                     
01582200   RPARENTSEMICOLONSET:=RPARENTSET OR SEMICOLONSET;                                 
01582300   COLONOFSET            :=COLONSET OR OFSET;                                       
01582400   SEMICOLONRPARENTSET   :=SEMICOLONSET OR RPARENTSET;                              
01582500   COLONSEMICOLONSET     :=COLONSET OR SEMICOLONSET;                                
01582600   IDENTRPARENTSET       :=IDENTSET OR RPARENTSET;                                  
01582700   IDENTLPARENTSET       :=IDENTSET OR LPARENTSET;                                  
01582800   PROCFUNCSET            :=PROCSET OR FUNCSET;                                     
01582900                                                                                    
01583000   COMMACOLONOFSET       :=COMMACOLONSET OR OFSET;                                  
01583100   COMMACOLONOFSEMICOLONCASESET:=COMMACOLONOFSET OR SEMICOLONSET OR                 
01583200            CASESET;                                                                
01583300   COMMACOLONLPARENTSET:=COMMACOLONSET OR LPARENTSET;                               
01583400   COMMACOLONRPARENTSET:=COMMACOLONSET OR RPARENTSET;                               
01583500   COMMARBRACKOFSET:=COMMARBRACKSET OR OFSET;                                       
01583600   COMMACOLONSEMICOLONSET:=COMMACOLONSET OR SEMICOLONSET;                           
01583700   TODOWNTODOSET         :=(TOSET OR DOSET) & SETB(DOWNTOSY);                       
01583800   BECOMESTODOWNTODOSET  :=TODOWNTODOSET OR BECOMESSET;                             
01583900   COMMACOLONSEMICOLONOFSET:=COMMACOLONOFSET OR SEMICOLONSET;                       
01584000   SEMICOLONENDELSEUNTILSET:=SEMICOLONUNTILSET OR ELSESET OR ENDSET;                
01584100   BEGINPROCFUNCSET      :=BEGINSET OR PROCSET OR FUNCSET;                          
01584200   COMMASEMICOLONRPARENTSET:=COMMASET OR SEMICOLONRPARENTSET;                       
01584300   IDENTVARPROCFUNCSET   :=IDENTSET OR VARSET OR PROCSET OR FUNCSET;                
01584400                                                                                    
01584500   CONSTBEGSYS:=FALSE & SETB(ADDOP) & SETB(INTCONST) & SETB(REALCONST)              
01584600         & SETB(STRINGCONST) & SETB(IDENT);                                         
01584700   SIMPTYPEBEGSYS:=CONSTBEGSYS & SETB(LPARENT);                                     
01584800   TYPEDELS:=FALSE & SETB(ARRAYSY) & SETB(RECORDSY) & SETB(SETSY)                   
01584900         & SETB(FILESY);                                                            
01585000   TYPEBEGSYS:=(SIMPTYPEBEGSYS & SETB(ARROW) & SETB(PACKEDSY))                      
01585100         OR TYPEDELS;                                                               
01585200   BLOCKBEGSYS:=FALSE & SETB(LABELSY) & SETB(CONSTSY) & SETB(TYPESY)                
01585300         & SETB(VARSY) & SETB(PROCSY) & SETB(FUNCSY) & SETB(BEGINSY)                
01585400         & SETB(FORMATSY);                                                          
01585500   SELECTSYS:=FALSE & SETB(ARROW) & SETB(PERIOD) & SETB(LBRACK);                    
01585600   FACBEGSYS:=FALSE & SETB(INTCONST) & SETB(REALCONST) &SETB(STRINGCONST)           
01585700         & SETB(IDENT) & SETB(LPARENT) & SETB(LBRACK) & SETB(NOTSY);                
01585800   STATBEGSYS:=FALSE & SETB(BEGINSY) & SETB(GOTOSY) & SETB(IFSY)                    
01585900         & SETB(CASESY) & SETB(WHILESY) & SETB(REPEATSY)                            
01586000         & SETB(FORSY) & SETB(WITHSY);                                              
01586100                                                                                    
01586200   FSYS:=(BLOCKBEGSYS OR STATBEGSYS) AND NOT CASESET;                               
01586300                                                                                    
01586400 %=======================================================================           
01586500 % SET UP READY FOR ENTERING DATA INTO HEAP (TABLES, STRUCTURES)                    
01586600 %=======================================================================           
01586700                                                                                    
01586800   LEXLEVEL:=1;                                                                     
01586900   TOP:=0;                                                                          
01587000   FNAME(TOP):=NIL; FLABEL(TOP):=NIL; OCCUR(TOP):=BLCK;                             
01587100   A:=3;                                                                            
01587200   POOLMAX:=6138;                                                                   
01587300                                                                                    
01587400 %=======================================================================           
01587500 % ENTER STANDARD NAMES, TYPES AND OBJECTS INTO TABLE                               
01587600 %=======================================================================           
01587700                                                                                    
01587800   KOLD:=12;                                                                        
01587900   P0:=POINTER(NAMEBUF[0]);                                                         
01588000   P1:=P0+1;                                                                        
01588100                                                                                    
01588200   % STANDARD TYPES                                                                 
01588300   % ==============                                                                 
01588400   NEW(INTPTR,OTHERSTRUCTSIZE);                                                     
01588500   SWORDS(INTPTR):=INTSIZE; FORM(INTPTR):=SCALAR;                                   
01588600   SCALKIND(INTPTR):=STANDARD;                                                      
01588700   BITS(INTPTR):=INTBITSIZE;                                                        
01588800   NEW(REALPTR,OTHERSTRUCTSIZE);                                                    
01588900   SWORDS(REALPTR):=REALSIZE; FORM(REALPTR):=SCALAR;                                
01589000   BITS(REALPTR):=REALBITSIZE;                                                      
01589100   SCALKIND(REALPTR):=STANDARD;                                                     
01589200   NEW(CHARPTR,OTHERSTRUCTSIZE);                                                    
01589300   SWORDS(CHARPTR):=CHARSIZE; FORM(CHARPTR):=SCALAR;                                
01589400   BITS(CHARPTR):=CHARBITSIZE;                                                      
01589500   SCALKIND(CHARPTR):=STANDARD;                                                     
01589600   NEW(BOOLPTR,OTHERSTRUCTSIZE);                                                    
01589700   SWORDS(BOOLPTR):=BOOLSIZE; FORM(BOOLPTR):=SCALAR;                                
01589800   BITS(BOOLPTR):=BOOLBITSIZE;                                                      
01589900   SCALKIND(BOOLPTR):=DECLARED;                                                     
01590000   NEW(NILPTR,OTHERSTRUCTSIZE);                                                     
01590100   SWORDS(NILPTR):=PTRSIZE; FORM(NILPTR):=POINTERS;                                 
01590200   ELTYPE(NILPTR):=NIL;                                                             
01590300   BITS(NILPTR):=PTRBITSIZE;                                                        
01590400   %                                                                                
01590500   NEW(CHARBUFPTR,OTHERSTRUCTSIZE);                                                 
01590600   FORM(CHARBUFPTR):=ARRAYS;                                                        
01590700   PACKED(CHARBUFPTR):=PACKEDSTRUC;                                                 
01590800   BITS(CHARBUFPTR):=CHARBITSIZE;                                                   
01590900   SWORDS(CHARBUFPTR):=132;                                                         
01591000   AELTYPE(CHARBUFPTR):=CHARPTR;                                                    
01591100   ELSPERWORD(CHARBUFPTR):=CHARSPERWORD;                                            
01591200   %                                                                                
01591300   NEW(WORDBUFPTR,OTHERSTRUCTSIZE);                                                 
01591400   FORM(WORDBUFPTR):=ARRAYS;                                                        
01591500   PACKED(WORDBUFPTR):=UNPACKEDSTRUC;                                               
01591600   BITS(WORDBUFPTR):=BITSPERWORD;                                                   
01591700   SWORDS(WORDBUFPTR):=80;                                                          
01591800   AELTYPE(WORDBUFPTR):=REALPTR;                                                    
01591900   ELSPERWORD(WORDBUFPTR):=1;                                                       
01592000   %                                                                                
01592100   NEW(SP1,SUBRANGESTRUCTSIZE);                                                     
01592200   FORM(SP1):=SUBRANGE;                                                             
01592300   RANGETYPE(SP1):=INTPTR;                                                          
01592400   SMIN(SP1):=1;  SMAX(SP1):=132;                                                   
01592500   SWORDS(SP1):=INTSIZE;                                                            
01592600   BITS(SP1):=8;                                                                    
01592700   %                                                                                
01592800   INXTYPE(CHARBUFPTR):=SP1;                                                        
01592900   INXTYPE(WORDBUFPTR):=SP1;                                                        
01593000   %                                                                                
01593100   NEW(TEXTPTR,OTHERSTRUCTSIZE);                                                    
01593200   SWORDS(TEXTPTR):=CHARSIZE; FORM(TEXTPTR):=FILES;                                 
01593300   ORIGFILTYPE(TEXTPTR):=CHARPTR;                                                   
01593400   FILTYPE(TEXTPTR):=CHARBUFPTR;                                                    
01593500   PACKED(TEXTPTR):=PACKEDSTRUC;                                                    
01593600   TEXTFILE(TEXTPTR):=TEXTFIL;                                                      
01593700                                                                                    
01593800                                                                                    
01593900   % STANDARD NAMES                                                                 
01594000   % ==============                                                                 
01594100   CREATE(0);                                                                       
01594200   IDTYPE(CP):=INTPTR; KLASS(CP):=TYPES;                                            
01594300   ENTERID(CP);                                                                     
01594400   CREATE(1);                                                                       
01594500   IDTYPE(CP):=REALPTR; KLASS(CP):=TYPES;                                           
01594600   ENTERID(CP);                                                                     
01594700   CREATE(2);                                                                       
01594800   IDTYPE(CP):=CHARPTR; KLASS(CP):=TYPES;                                           
01594900   ENTERID(CP);                                                                     
01595000   CREATE(3);                                                                       
01595100   IDTYPE(CP):=BOOLPTR; KLASS(CP):=TYPES;                                           
01595200   ENTERID(CP);                                                                     
01595300   CP1:=NIL;                                                                        
01595400   FOR I:=4 UPTO 5 DO BEGIN                                                         
01595500     CREATE(I);                                                                     
01595600     IDTYPE(CP):=BOOLPTR; NEXT(CP):=CP1; KLASS(CP):=KONST;                          
01595700     VALUES(CP):=(I-4); ENTERID(CP); CP1:=CP;                                       
01595800   END;                                                                             
01595900   FCONST(BOOLPTR):=CP;                                                             
01596000   CREATE(6);                                                                       
01596100   IDTYPE(CP):=NILPTR; KLASS(CP):=KONST;                                            
01596200   VALUES(CP):=-549755813887;                                                       
01596300   ENTERID(CP);                                                                     
01596400   CREATE(7);    %MAXINT                                                            
01596500   IDTYPE(CP) := INTPTR;  KLASS(CP) := KONST;                                       
01596600   VALUES(CP) := 549755813887;                                                      
01596700   ENTERID(CP);                                                                     
01596800   CREATE(PROCNAMESTOP+3);      % TEXT                                              
01596900   KLASS(CP):=TYPES;                                                                
01597000   IDTYPE(CP):=TEXTPTR;                                                             
01597100   ENTERID(CP);                                                                     
01597200   %                                                                                
01597300   %FILE NAMES                                                                      
01597400   CREATE(PROCNAMESTOP+1);                                                          
01597500   KLASS(CP):=VARS; IDTYPE(CP):=TEXTPTR;                                            
01597600   VLEV(CP):=BASELVL; VADDR(CP):=ADDRIFILE;                                         
01597700   ENTERID(CP);                                                                     
01597800   INPUTPTR := CP;                                                                  
01597900   %                                                                                
01598000   CREATE(PROCNAMESTOP+2);                                                          
01598100   KLASS(CP):=VARS; IDTYPE(CP):=TEXTPTR;                                            
01598200   VLEV(CP):=BASELVL; VADDR(CP):=ADDROFILE;                                         
01598300   ENTERID(CP);                                                                     
01598400   OUTPUTPTR := CP;                                                                 
01598500                                                                                    
01598600                                                                                    
01598700   % STANDARD FUNCTIONS                                                             
01598800   %===================                                                             
01598900   NAMEBUF[0].[47:8]:=LENGTH:=0;                                                    
01599000   NEWIDENTRECORDWITHNAME(CP1);                                                     
01599100   KLASS(CP1):=VARS;  VKIND(CP1):=ACTUAL;                                           
01599200   NEXT(CP1):=NIL;  IDTYPE(CP1):=REALPTR;                                           
01599300   FOR I:=FNNAMESTART UPTO FNNAMESTOP DO BEGIN                                      
01599400     REPLACE P1 BY SNAME[(I)*12] FOR KNEW:KOLD UNTIL = " ", " ";                    
01599500     NAMEBUF[0].[47:8]:=(LENGTH:=(KOLD-KNEW)+1);                                    
01599600     NEW(CP,PROCFUNCSIZE+(LENGTH DIV CHARSPERWORD)+1);                              
01599700     REPLACE POINTER(HEAP[CP+PROCFUNCSIZE]) BY NAMEBUF0 FOR (LENGTH+1);             
01599800     NAME(CP):=CP+PROCFUNCSIZE;                                                     
01599900     KLASS(CP):=FUNC; PFDECLKIND(CP):=STANDARD;                                     
01600000     KEY(CP):=(I-FNNAMESTART+1);                                                    
01600100     PFSTD(CP):=IF(I<=FNNAMESTART+16) THEN STDPASCAL ELSE NONSTDPASCAL;             
01600200     IF((I>=PROCPARAMS1) AND (I<=PROCPARAMS2)) THEN BEGIN                           
01600300       NEXT(CP):=CP1;                                                               
01600400       FPROCPARAM(CP):=PASSPROC;                                                    
01600500       IDTYPE(CP):=REALPTR;     % FOR PASSING FUNCTION PARAMETERS                   
01600600     END ELSE BEGIN                                                                 
01600700       IF (I=PROCRANDOM) THEN BEGIN                                                 
01600800         NAMEBUF[0].[47:8]:=LENGTH:=0;                                              
01600900         NEWIDENTRECORDWITHNAME(CP1);                                               
01601000         KLASS(CP1):=VARS;  VKIND(CP1):=FORMAL;                                     
01601100         NEXT(CP1):=NIL;  IDTYPE(CP1):=REALPTR;                                     
01601200         NEXT(CP):=CP1;                                                             
01601300         FPROCPARAM(CP):=PASSPROC;                                                  
01601400         IDTYPE(CP):=REALPTR;   % FOR PASSING FUNCTION PARAMETERS                   
01601500       END ELSE BEGIN                                                               
01601600         NEXT(CP):=NIL;                                                             
01601700         FPROCPARAM(CP):=INLINECODE;                                                
01601800       END;                                                                         
01601900     END;                                                                           
01602000     ENTERID(CP);                                                                   
01602100   END;                                                                             
01602200                                                                                    
01602300                                                                                    
01602400   % STANDARD PROCEDURES                                                            
01602500   % ===================                                                            
01602600   FOR I:=PROCNAMESTART UPTO PROCNAMESTOP DO BEGIN                                  
01602700     CREATE(I);                                                                     
01602800     KLASS(CP):=PROC; PFDECLKIND(CP):=STANDARD;                                     
01602900     KEY(CP):=(I-PROCNAMESTART+1);                                                  
01603000     CASE KEY(CP) OF BEGIN                                                          
01603100     1:2:3:6:7:13:15:16:17:18:19:20:21:                                             
01603200       PFSTD(CP):=STDPASCAL;                                                        
01603300     4:5:8:9:10:11:12:14:22:23:                                                     
01603400  $SET OMIT = NOT CODETEST                                                          
01603500   24:                                                                              
01603600  $POP OMIT                                                                         
01603700       PFSTD(CP):=NONSTDPASCAL;                                                     
01603800     END;                                                                           
01603900     ENTERID(CP);                                                                   
01604000   END;                                                                             
01604100                                                                                    
01604200                                                                                    
01604300   % UNDECLARED OBJECTS TO SIMPLIFY ERROR HANDLING                                  
01604400   % =============================================                                  
01604500   REPLACE P1 BY "?";                                                               
01604600   NAMEBUF[0].[47:8]:=1;                                                            
01604700   %                                                                                
01604800   NEW(UTYPPTR,OTHERIDENTSIZE+1); PUTNAME1(UTYPPTR);                                
01604900   KLASS(UTYPPTR):=TYPES;                                                           
01605000   NEW(UCSTPTR,OTHERIDENTSIZE+1); PUTNAME1(UCSTPTR);                                
01605100   KLASS(UCSTPTR):=KONST;                                                           
01605200   NEW(UVARPTR,OTHERIDENTSIZE+1); PUTNAME1(UVARPTR);                                
01605300   KLASS(UVARPTR):=VARS;                                                            
01605400   NEW(UFLDPTR,OTHERIDENTSIZE+1); PUTNAME1(UFLDPTR);                                
01605500   KLASS(UFLDPTR):=FIELD;                                                           
01605600   NEW(UPRCPTR,PROCFUNCSIZE+1); PUTNAME2(UPRCPTR);                                  
01605700   KLASS(UPRCPTR):=PROC;                                                            
01605800   PFDECLKIND(UPRCPTR):=DECLARED;  PFKIND(UPRCPTR):=ACTUAL;                         
01605900   NEW(UFCTPTR,PROCFUNCSIZE+1); PUTNAME2(UFCTPTR);                                  
01606000   KLASS(UFCTPTR):=FUNC;                                                            
01606100   PFDECLKIND(UFCTPTR):=DECLARED;  PFKIND(UFCTPTR):=ACTUAL;                         
01606200                                                                                    
01606300 %======================================================================            
01606400 % OK, PREPARE TO LAUNCH INTO WORK                                                  
01606500 %=======================================================================           
01606600                                                                                    
01606700   LEXLEVEL:=2;                                                                     
01606800   TOP:=1;                                                                          
01606900   FNAME(TOP):=NIL; FLABEL(TOP):=NIL; OCCUR(TOP):=BLCK;                             
01607000   LASTPROCDIREC := 29;                                                             
01607100                                                                                    
01607200 END; % OF INITIALIZE                                                               
01607300                                                                                    
01607400                                                                                    
01607500 % MAIN START PART.....                                                             
01607600   INITIALIZE;                                                                      
01607700                                                                                    
01607800   % NOW PROCESS THE PASCAL PROGRAM                                                 
01607900                                                                                    
01608000   %                                                                                
01608100   OPENCODEFILE;                                                                    
01608200   INSYMBOL;                                                                        
01608300   IF (SYMBOL = PROCSY) THEN BEGIN                                                  
01608400     INSYMBOL;                                                                      
01608500   END ELSE BEGIN                                                                   
01608600     ERROR(2502);                                                                   
01608700   END;                                                                             
01608800   IF (SYMBOL=IDENT) THEN BEGIN                                                     
01608900     NEW(OBPROCP,PROCFUNCSIZE+(LENGTH DIV CHARSPERWORD)+1);                         
01609000     REPLACE POINTER(HEAP[OBPROCP+PROCFUNCSIZE]) BY NAMEBUF0                        
01609100       FOR (LENGTH);                                                                
01609200     NAME(OBPROCP):=PROCFUNCSIZE+OBPROCP;                                           
01609300     IDTYPE(OBPROCP):=NIL;                                                          
01609400     BINDIN(OBPROCP):=DONTBIND;                                                     
01609500     PFLEV(OBPROCP):=1;                                                             
01609600     NEXT(OBPROCP):=NIL;                                                            
01609700     KLASS(OBPROCP):=PROC;                                                          
01609800     PFDECLKIND(OBPROCP):=DECLARED;                                                 
01609900     PFSTD(OBPROCP):=NONSTDPASCAL;                                                  
01610000     PFKIND(OBPROCP):=ACTUAL;                                                       
01610100     FPARAMLIST(OBPROCP):=NIL;                                                      
01610200     %  PFDPLMT(OBPROCP):=0;                                                        
01610300     %  ENTERID(OBPROCP);                                                           
01610400     INSYMBOL;                                                                      
01610500   END ELSE BEGIN                                                                   
01610600     ERROR(2503);                                                                   
01610700   END;                                                                             
01610800   IF (SYMBOL=LPARENT) THEN BEGIN                                                   
01610900     ERROR(6501);                                                                   
01611000     IF WARNINGSTOG THEN BEGIN                                                      
01611100       SKIP(RPARENTSET);                                                            
01611200     END ELSE BEGIN                                                                 
01611300       WHILE(SYMBOL NEQ RPARENT) DO BEGIN                                           
01611400         INSYMBOL;                                                                  
01611500       END;                                                                         
01611600     END;                                                                           
01611700     INSYMBOL;                                                                      
01611800   END;                                                                             
01611900   IF (SYMBOL = SEMICOLON) THEN BEGIN                                               
01612000     INSYMBOL;                                                                      
01612100   END ELSE BEGIN                                                                   
01612200     ERROR(2500); SKIP(BLOCKBEGSYS);                                                
01612300   END;                                                                             
01612400   STATSMAX := STATSMIN := -2;                                                      
01612500   ANYSTATISTICSFLAG := FALSE;                                                      
01612600   BLOCK(FSYS,PERIOD,NIL,ENTRYPOINT,2,STATISTICSTOG,0);                             
01612700   D1STACK[2]:=ASKFORPCW(ENTRYPOINT) & 0 [47:1];                                    
01612800   IF (SYMBOL NEQ PERIOD) THEN ERROR(2501);                                         
01612900   DO UNTIL READNEXTLINE(CARDWBUF);                                                 
01613000   IF (DATAPOOL > 0) THEN BEGIN                                                     
01613100     FLUSHPOOL;                                                                     
01613200   END;                                                                             
01613300   CLOSECODEFILE(FALSE);                                                            
01613400   GO TO GOODBYE;                                                                   
01613500 SHEERANDUTTERDISASTER:                                                             
01613600   CLOSECODEFILE(TRUE);                                                             
01613700 GOODBYE:                                                                           
01613800 END.                                                                               